Option Explicit
'/////////////////////////////////////////////////////////////////////////////
'// Description:
'// Retrieve Information Tip for a File as Displayed in Explorer view XP
'//
'// Requires:
'// DLL version shell32.dll version 4.71 or later
'// Operating systems:
'// Win2000, WinNT 4.0 with Internet Explorer*4.0, Win98, Win95 with Internet Explorer*4.0
'// Date: 29th June 2003
'// Tested: WinXP / Excel2000
'// By Ivan F Moala: http//www.XcelFiles.com
'// Amend 12th April 2004
'// Tested: WinXp / Excel2003
'//
'/////////////////////////////////////////////////////////////////////////////
Dim strShtName As String
Dim objFolder As Object
Dim strFullPath As String
Dim blnCreateLink As Boolean
Dim blnStatus As Boolean
Dim objShell As Object
'ParseName Method
'--------------------------------------------------------------------------------
'Creates and returns a FolderItem object that represents a specified item.
'
'Syntax
'
'ppid = Folder.ParseName(bName)
'Parameters
'
'bName Required. A string that specifies the name of the item.
'Return Value
'An object reference to the FolderItem object.
'Remarks
'ParseName should not be used for virtual folders such as My Documents.
Sub GetFileDetails()
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Dim strFilename As String
Dim strCap As String, strMsg As String
'// Must be a variant
Dim vDirNameSpace As Variant
'// Get File name
strFilename = Application.GetOpenFilename
If strFilename = "False" Then Exit Sub
'// Build details now
On Error GoTo ErrF
10 vDirNameSpace = FilePathOnly(strFilename)
20 strFilename = FileNameOnly(strFilename)
On Error GoTo 0
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(vDirNameSpace)
If (Not objFolder Is Nothing) Then
Set objFolderItem = objFolder.ParseName(strFilename)
If (Not objFolderItem Is Nothing) Then
strCap = "Info on: " & strFilename
strMsg = "Dir:=" & vDirNameSpace & vbCrLf
MsgBox strMsg & objFolder.GetDetailsOf(objFolderItem, -1), vbInformation, strCap
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
Exit Sub
ErrF:
MsgBox Err.Number & ":" & Err.Description & " @ Line " & Erl, vbCritical
End Sub
Function FileNameOnly(strFile As String) As String
Dim MyFile As String
Dim ArrName As Variant
#If VBA6 Then
'// Xl2000+ Reverse the string
MyFile = StrReverse(strFile)
'// Get the string to the left of the first \ and reverse it
MyFile = StrReverse(Left(MyFile, InStr(MyFile, "\") - 1))
FileNameOnly = MyFile
#Else
'// Xl97 Tom Ogilvy
ArrName = Evaluate("{""" & Application.Substitute( _
strFile, "\", """,""") & """}")
FileNameOnly = ArrName(UBound(ArrName))
#End If
End Function
Function FilePathOnly(FullFileName As String) As String
'// Use of favorites returns file only
On Error Resume Next
FilePathOnly = Left(FullFileName, Len(FullFileName) - Len(Dir(FullFileName, vbHidden + vbSystem)) - 1)
End Function
