Excel VBA - PDF文件属性 [英] Excel VBA - PDF file properties
问题描述
第一次海报,但长期以来在此网站上找到VBA和SQL解决方案的粉丝。我有一个VBA子例程,旨在查找用户指定的目录中的所有PDF文件。该程序通过所有子文件夹执行递归,并生成如下电子表格:
列A:完整的文件路径(C:\Users\Records\NumberOne.pdf )
列B:包含文件的文件夹路径(C:\Users\Records\)
$ b $列C:文件名本身(NumberOne.pdf)
到目前为止,程序(代码如下)完美无缺。我已经使用它来搜索一个包含50,000个PDF文件的目录,并且每次成功生成电子表格(程序的总经过时间通常在大型目录中为5-10分钟)。
问题是我想添加列D以捕获创建PDF文件的日期。我已经在Google上进行了搜索并努力了几个小时,尝试了如FSO.DateCreated等技术,没有任何工作。如果FSO.DateCreated是我需要的,我不知道在我的子程序中插入它以使其工作。通常我收到一个错误,对象不支持该属性或方法。有没有人知道我可以在我的程序中插入适当的代码来查找每个PDF创建的日期,并将其放在输出电子表格的D列中?
Sub GetFiles()
' - 通过一个有针对性的文件夹搜索无限次的搜索并找到所有PDF文件
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim j As Long
Dim ThisEntry As String
Dim strDir As String
Dim FSO As Object
Dim strFolder As String
Dim strName As String
Dim DateCreated As Date' - (可能是String?)
Dim strArr(1 To 1048576,1 To 1)As String,As As Long
Dim fldr As FileDialog
' - 打开对话框选择目录用户希望搜索
设置fldr = Application.FileDialog(msoFileDialogFolderPicker)
使用fldr
.Title =Sele ct您想要搜索的目录
.AllowMultiSelect = False
如果.Show<> -1然后
Exit Sub
设置fldr = Nothing
Else
strDir = .SelectedItems(1)& \
结束如果
结束
' - 查看记录工作表;如果它不存在,创建它;如果它是现在的,清除目录
如果没有(wsExists(记录))然后
工作表.Add
与ActiveSheet
.Name =记录
结束使用
设置ws = ActiveSheet
Else
表(记录)。激活
范围(A1:IV1)。EntireColumn.Delete
设置ws = ActiveSheet
End if
' - SET搜索参数
让strName = Dir $(strDir&\&* .pdf)
而strName<> vbNullString
让i = i + 1
让strArr(i,1)= strDir& strName
让strName = Dir $()
循环
' - 通过子文件夹无限制的重新获取
设置FSO = CreateObject(Scripting.FileSystemObject)
调用recurseSubFolders(FSO.GetFolder(strDir),strArr(),i)
Set FSO = Nothing
' - 在输出工作表上创建COLUMN HEADERS
带ws
Range(A1)Value =AbsolutePath
范围(B1)Value =FolderPath
范围(C1)Value =FileName
范围(D1)。值=DateCreated
结束
如果我> 0然后
ws.Range(A2)。调整大小(i).Value = strArr
如果
lr = Cells(Rows.Count,1).End xlUp).Row
对于i = 1 To lr
ThisEntry = Cells(i,1)
' - 从STRING $提取文件夹路径和文件名b $ b对于j = Len(ThisEntry)到1步-1
如果Mid(ThisEntry,j,1)= Application.PathSeparator然后
单元格(i,2)=左(ThisEntry,j)
单元格(i,3)=中间(ThisEntry,j + 1)
退出
结束如果
下一步j
下一步i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
----------
Private Sub recurseSubFolders(ByRef Folder As Object,_
ByRef strArr()As String,_
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
对于每个SubFolder在Folder.SubFolders
让strNam e = Dir $(SubFolder.Path& \& * .pdf)
尽管strName<> vbNullString
让i = i + 1
让strArr(i,1)= SubFolder.Path& \& strName
让strName = Dir $()
循环
调用recurseSubFolders(SubFolder,strArr(),i)
下一个
End Sub
你的代码很好(除了一些缩进的问题)。我刚刚添加了从文件系统获取创建日期的指令,如下所示:
设置FSO = CreateObject( Scripting.FileSystemObject)
对于i = 1 To lr
ThisEntry = Cells(i,1)
' - 从STRING提取文件夹路径和文件名$ $ $ $ b对于j = Len(ThisEntry)到1步-1
如果Mid(ThisEntry,j,1)= Application.PathSeparator然后
单元格(i,2)=左(ThisEntry,j)
Cells(i,3)= Mid(ThisEntry,j + 1)
单元格(i,4)= FSO.GetFile(ThisEntry).DateCreated
退出
结束如果
下一步j
下一步我
我不知道为什么你不能使用FSO对象,但我相信这可能是因为下面的几行将它设置为没有,所以我在第一个For循环之前再次实例化了:
Set FSO = CreateObject(Scripting.FileSystemObject)
希望这有帮助,
宏Guru
first-time poster but long-time fan for finding VBA and SQL solutions on this site. I have a VBA subroutine that is designed to find all PDF files within a directory that the user designates. The program does recursions through all subfolders and generates a spreadsheet as follows:
Column A: complete file path ("C:\Users\Records\NumberOne.pdf")
Column B: folder path containing the file ("C:\Users\Records\")
Column C: the file name itself ("NumberOne.pdf")
Up to this point, the program (code below) works flawlessly. I've used it to search a directory with over 50,000 PDF files, and it successfully generates the spreadsheet every time (total elapsed time for the program is usually 5-10 minutes in large directories).
The problem is that I want to add Column D to capture the date that the PDF file was created. I have Googled this and labored over it for hours, trying techniques like FSO.DateCreated and so forth, and nothing has worked. If FSO.DateCreated is what I need, I'm not sure where to insert it in my subroutine to make it work. Usually I get an error that the object does not support that property or method. Does anybody happen to know where I can insert the proper code for my program to find the date each PDF was created and drop it into Column D on my output spreadsheet?
Sub GetFiles()
'-- RUNS AN UNLIMITED RECURSION SEARCH THROUGH A TARGETED FOLDER AND FINDS ALL PDF FILES WITHIN
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim j As Long
Dim ThisEntry As String
Dim strDir As String
Dim FSO As Object
Dim strFolder As String
Dim strName As String
Dim DateCreated As Date '--(Possibly String?)
Dim strArr(1 To 1048576, 1 To 1) As String, i As Long
Dim fldr As FileDialog
'-- OPEN DIALOG BOX TO SELECT DIRECTORY THE USER WISHES TO SEARCH
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the directory you wish to search"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
Set fldr = Nothing
Else
strDir = .SelectedItems(1) & "\"
End If
End With
'-- LOOK FOR RECORDS WORKSHEET; IF IT DOES NOT EXIST, CREATE IT; IF IT DOES EXIST, CLEAR CONTENTS
If Not (wsExists("records")) Then
Worksheets.Add
With ActiveSheet
.Name = "records"
End With
Set ws = ActiveSheet
Else
Sheets("records").Activate
Range("A1:IV1").EntireColumn.Delete
Set ws = ActiveSheet
End If
'-- SET SEARCH PARAMETERS
Let strName = Dir$(strDir & "\" & "*.pdf")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & strName
Let strName = Dir$()
Loop
'-- UNLIMITED RECURSIONS THROUGH SUBFOLDERS
Set FSO = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(FSO.GetFolder(strDir), strArr(), i)
Set FSO = Nothing
'-- CREATE COLUMN HEADERS ON OUTPUT WORKSHEET
With ws
Range("A1").Value = "AbsolutePath"
Range("B1").Value = "FolderPath"
Range("C1").Value = "FileName"
Range("D1").Value = "DateCreated"
End With
If i > 0 Then
ws.Range("A2").Resize(i).Value = strArr
End If
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
ThisEntry = Cells(i, 1)
'-- EXTRACT FOLDER PATH AND FILE NAME FROM STRING
For j = Len(ThisEntry) To 1 Step -1
If Mid(ThisEntry, j, 1) = Application.PathSeparator Then
Cells(i, 2) = Left(ThisEntry, j)
Cells(i, 3) = Mid(ThisEntry, j + 1)
Exit For
End If
Next j
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
----------
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "\" & "*.pdf")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub
Your code is fine (beside some issues with indentation). I just added the instruction to get the creation date from the file system, as you can see below:
Set FSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To lr
ThisEntry = Cells(i, 1)
'-- EXTRACT FOLDER PATH AND FILE NAME FROM STRING
For j = Len(ThisEntry) To 1 Step -1
If Mid(ThisEntry, j, 1) = Application.PathSeparator Then
Cells(i, 2) = Left(ThisEntry, j)
Cells(i, 3) = Mid(ThisEntry, j + 1)
Cells(i, 4) = FSO.GetFile(ThisEntry).DateCreated
Exit For
End If
Next j
Next i
I don't know why you weren't able to use the FSO object, but I believe it can be because few lines below you set it to nothing, so I instantiated it again before the first For cycle:
Set FSO = CreateObject("Scripting.FileSystemObject")
Hope this helps, The Macro Guru
这篇关于Excel VBA - PDF文件属性的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!