I have a macro I found on the internet many years ago and have found many uses for it.
It collects a basic listing of file names and paths.
I'm using Office 365 Pro Plus, Excel 32 bit.
I would like some people in another office to collect information for me but they are using Office 365 Pro Plus, Excel 64 bit.
I do not have 64bit to test it on.
Is there a way to install both 64 bit and 32 version of Excel and choose which I use?
I've converted a couple of lines in the macro from info I found on the internet but it still doesn't run.
Any ideas?
Excel File Attached
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'API declarations
'32 bit code
'Declare Function SHGetPathFromIDList Lib "shell32.dll" _
'Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'Declare Function SHBrowseForFolder Lib "shell32.dll" _
'Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
'64 bit code
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Long
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
Function Get_File(f_cell)
'Pull the path off the file name
'in the excel cell type "=get_file(a1)"
Top:
If InStr(1, f_cell, "\") Then
f_cell = Right(Trim(f_cell), Len(Trim(f_cell)) - InStr(1, f_cell, "\"))
GoTo Top
End If
Get_File = f_cell
End Function
Function get_dwg_number(f_cell)
'pull drawing number from the left to the first space
get_dwg_number = Left(Get_File(f_cell), InStr(1, f_cell, " ") - 1)
End Function
Function get_desc(f_cell)
'Pull description after the drawing number and first space
get_desc = Right(Trim(Get_File(f_cell)), Len(Trim(Get_File(f_cell))) - InStr(1, Get_File(f_cell), " "))
get_desc = Left(get_desc, Len(get_desc) - 4)
End Function
-------------------------
Private Sub CommandButton1_Click()
TestListFilesInFolder
End Sub
Sub TestListFilesInFolder()
'Set column headers
With Range("A1")
.Font.Bold = True
.Font.Size = 12
End With
Range("A1").Formula = "Files in " & TextBox1
' Range("B1").Formula = "Path and File:"
' Range("C1").Formula = "File Size:"
' Range("D1").Formula = "Date Created:"
' Range("E1").Formula = "Date Last Modified:"
' Range("F1").Formula = "Owner:"
' Range("H1").Formula = "Path:"
' Range("I1").Formula = "File:"
' Range("I1").Formula = "File:"
' Range("J1").Formula = "Programmer:"
' Range("K1").Formula = "Charged Out:"
' Range("L1").Formula = "Update Date:"
' Range("M1").Formula = "Days old:"
' Range("N1").Formula = "EC1:"
' Range("O1").Formula = "EC2:"
' Range("P1").Formula = "EC3:"
Range("A1:P1").Font.Bold = True
Range("A2:P2500").Font.Bold = False
'Add comments
' Range("N1").Select
' Selection.ClearComments
' Range("O1").Select
' Selection.ClearComments
'
' Range("N1").AddComment
' Range("N1").Comment.Visible = False
' Range("N1").Comment.Text Text:="Is this charged out" & Chr(10) & "in MOM?" & Chr(10) & ""
' Range("N1").Select
' Range("O1").AddComment
' Range("O1").Comment.Visible = False
' Range("O1").Comment.Text Text:="Has it been charged out" & Chr(10) & "more than 30 days?" & Chr(10) & ""
' Range("O1").Select
If TextBox1 > "" Then
ListFilesInFolder TextBox1, CheckBox1
Else
MsgBox "Enter a path to list."
End If
End Sub
Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
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 = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
'display file properties
If IncludeSubfolders Then
Cells(r, 1).Formula = FileItem.path
Else
Cells(r, 1).Formula = FileItem.Name
End If
' Cells(r, 3).Formula = FileItem.Size
' Cells(r, 4).Formula = FileItem.DateCreated
' Cells(r, 5).Formula = FileItem.DateLastModified
' Cells(r, 6).Formula = GetFileOwner(SourceFolder.path, FileItem.Name)
r = r + 1 ' next row number
x = SourceFolder.path
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.path, True
Next SubFolder
End If
Columns("A:A").EntireColumn.AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Function GetFileOwner(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
GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 8)
Else
GetFileOwner = ""
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Sub CommandButton2_Click()
' BrowseForFolder
Dim dirInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Set Default Root folder = Desktop
dirInfo.pidlRoot = 0&
dirInfo.lpszTitle = "Browse directory!"
' Type of directory
dirInfo.ulFlags = &H1
' Show the Browse Dialog
x = SHBrowseForFolder(dirInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
TextBox1 = Left(path, pos - 1)
Else
MsgBox "Browse a Directory..."
CommandButton2_Click
End If
End Sub
Bookmarks