I'm running a macro which uses File System Object to get the Name and Title of a large number of PDF documents.
Because of the large memory required, it looks like my Excel file is about to crash, it goes blank with File Not Responding warning.
Is there a way to stop this from occurring.
Is the file really about to crash or is it that there's no memory left for other tasks?
I don't know if the PDF files are actually opened in the background to get the Title property.
Dim Row As Long
Sub File_Details()
Dim sFolder As FileDialog
On Error Resume Next
Set sFolder = Application.FileDialog(msoFileDialogFolderPicker)
If sFolder.Show = -1 Then
Row = 0
File_Details_List_Files sFolder.SelectedItems(1), True
End If
End Sub
Private Sub File_Details_List_Files(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean)
Dim fso As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem As Object
Dim strFile As String
Dim FileName As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(SourceFolderName)
Application.ScreenUpdating = False
If Row = 0 Then Row = ActiveCell.Row
With CreateObject("Scripting.Dictionary")
For Each FileItem In SourceFolder.Files
.Item(strFile) = Array(FileItem.Name)
Next FileItem
If .Count > 0 Then
For Each FileName In .Items
Rows(Row).Insert
Cells(Row, 3).Formula = FileName(LBound(FileName))
Cells(Row, 4).Formula = Get_File_Detail_Title(SourceFolder.Path, FileName(LBound(FileName)))
Row = Row + 1
Next FileName
End If
End With
Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
End Sub
Function Get_File_Detail_Title(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_Detail_Title = objFolder.GetDetailsOf(objFolderItem, 21) '10 (Windows xp), 21 (Windows Vista, Windows 7, Windows 8)
End If
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
End Function
Bookmarks