Kenneth, your macro works very well but it is so different to the initial one I was using, and I'm finding it difficult to integrate with the rest of the VB project (not shown initially because I didn't think it was relevant when I posted). The detailed code is shown below. The items which I cannot resolve include the following.
1. In addition to the hyperlink output, I also have others including Subject, Author and Title. These are Windows file attributes. Refer to Code 1.
2. The cell output from the initial code included the hyperlink with the folder path written in. I still need this because I was using another macro to open up Windows Explorer using the cell output (from a right click menu). Refer to Code 2a and 2b.
3. For each iteration I need to add a row into Excel, at the moment doing this by Rows(r).Insert.
4. With the folder dialogue I would like this to remember the last location it was on.
Sorry if this is too much. Whatever you can assist with.
*** Code 1
Sub File_Attributes()
Dim sFolder As FileDialog
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
File_Attributes_List_Files sFolder.SelectedItems(1), True
End If
End Sub
Sub File_Attributes_List_Files(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim r As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = ActiveCell.Row
For Each FileItem In SourceFolder.Files
Rows(r).Insert
Cells(r, 2).Formula = Get_File_Attribute_Subject(SourceFolder.Path, FileItem.Name)
Cells(r, 3).Formula = Chr(61) & "HYPERLINK(" & Chr(34) & FileItem.Path & Chr(34) & "," & Chr(34) & FileItem.Name & Chr(34) & ")"
Cells(r, 4).Formula = GetFileDataAuthor(SourceFolder.Path, FileItem.Name)
Cells(r, 5).Formula = GetFileDataTitle(SourceFolder.Path, FileItem.Name)
r = r + 1
x = SourceFolder.Path
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
File_Attributes_List_Files SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Function Get_File_Attribute_Subject(ByVal Filepath As String, ByVal FileName As String)
Dim objFolder As Object
Dim objFolderItem As Object
Dim objShell As Object
FileName = StrConv(FileName, vbUnicode)
Filepath = StrConv(Filepath, vbUnicode)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
End If
If Not objFolderItem Is Nothing Then
Get_File_Attribute_Subject = objFolder.GetDetailsOf(objFolderItem, 22) '11 (Windows xp), 22 (Windows Vista, Windows 7, Windows 8)
Else
Get_File_Attribute_Subject = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Function GetFileDataAuthor(ByVal Filepath As String, ByVal FileName As String)
Dim objFolder As Object
Dim objFolderItem As Object
Dim objShell As Object
FileName = StrConv(FileName, vbUnicode)
Filepath = StrConv(Filepath, vbUnicode)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
End If
If Not objFolderItem Is Nothing Then
GetFileDataAuthor = objFolder.GetDetailsOf(objFolderItem, 20) '9 (Windows xp), 20 (Windows Vista, Windows 7, Windows 8)
Else
GetFileDataAuthor = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Function GetFileDataTitle(ByVal Filepath As String, ByVal FileName As String)
Dim objFolder As Object
Dim objFolderItem As Object
Dim objShell As Object
FileName = StrConv(FileName, vbUnicode)
Filepath = StrConv(Filepath, vbUnicode)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(StrConv(Filepath, vbFromUnicode))
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode))
End If
If Not objFolderItem Is Nothing Then
GetFileDataTitle = objFolder.GetDetailsOf(objFolderItem, 21) '10 (Windows xp), 21 (Windows Vista, Windows 7, Windows 8)
Else
GetFileDataTitle = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
*** Code 2a (under Workbook)
Option Explicit
Private Sub Workbook_Activate()
Run "Hide_Sheet"
Run "Open_Folder_Create_Menu"
End Sub
*** Code 2b
Const strMacro = "Open Explorer"
Sub Open_Folder_Create_Menu()
Dim cBut
Call Open_Folder_Remove_Menu
Set cBut = Application.CommandBars("Cell").Controls.Add(Temporary:=True)
With cBut
.Caption = strMacro
.Style = msoButtonCaption
.OnAction = "Open_Folder"
End With
End Sub
Sub Open_Folder_Remove_Menu()
On Error Resume Next
Application.CommandBars("Cell").Controls(strMacro).Delete
End Sub
Sub Open_Folder()
Dim Folder As String
Folder = Replace(ActiveCell.Formula, "=HYPERLINK(", "")
Folder = Replace(Left(Folder, InStr(Folder, ",") - 1), """", "")
Shell "C:\Windows\explorer.exe /select," & Folder, vbMaximizedFocus
End Sub
Reply With Quote
Originally Posted by Trying
