这让我发疯：我在PowerPoint VBA中有一个子项和一个函数。
从允许我选择一个目录开始。从子程序中调用的函数在目录中找到文件。我希望将其作为子功能之外的功能，因为我将需要多次使用它。
该子项仍在开发中，因此不会做很多事情，但是可以工作。如果我可以做某件事，该函数也可以工作-例如打开找到的文件（即取消注释下面的代码中的该行）-但是我一生都无法让它将filePath返回到子目录。请帮忙！
子：
ball.color = [UIColor orangeColor];
ball.colorBlendFactor = 1.0;
功能：
Sub ManagementSummaryMerge()
Dim folderPath As String
'select dir
Dim FldrPicker As FileDialog
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
folderPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
folderPath = folderPath
If folderPath = "" Then GoTo EndOfSub
'set _Main <= string I want to look for
Dim v As String
v = "_Main"
Dim fullFilePathIWantToSet As String
'set value of fullFilePathIWantToSet from findFile function
fullFilePathIWantToSet = findFile(folderPath, v)
'when I test, this MsgBox appears, but blank
MsgBox fullFilePathIWantToSet
'If I can get this working properly, I want to be able to do something like this:
'objFSO.CopyFile fullFilePathIWantToSet, duplicateFilePath
'Presentations.Open (duplicateFilePath)
'numSlides = ActivePresentation.Slides.Count
'etc
EndOfSub:
'let the sub end
End Sub
我是VBA的入门者，所以pva用我在网上可以找到的东西将其粘合在一起。由于findFile循环返回的是一个数组而不是字符串，所以它不起作用吗？我以为“退出功能”调用将消除该问题。
请原谅递归if语句-我这样做的人没有一种完全标准的方式来存储其ppts，但这会降低我想要的ppt的能力。子目录完成后，它本身将循环遍历所选目录的130个子目录，并且在每个子目录中，它将从六个不同的ppts抓取各种幻灯片并将其合并为一个，即将780 ppts的数据合并为130-我肯定想自动化的东西！
这是我在堆栈溢出上发布的第一个问题，所以我希望我已经清楚，正确地提出了这个问题。我已经广泛搜索了解决方案。希望解决方案对您有所帮助！预先非常感谢。
答案 0 :(得分：1)
这是需要使用Option Explicit的经典情况。
您在f中缺少filename，并且未将其检查为变量ilename而不是filename。
您应该将Option Explicit放在每个模块的顶部，并声明所有变量。我添加的GoTo语句也缺少标签。
注意：您正在对所选文件夹中的文件名进行全字符串区分大小写的匹配。
Option Explicit
Sub ManagementSummaryMerge()
Dim folderPath As String, FldrPicker As FileDialog, pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
folderPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
folderPath = folderPath
If folderPath = "" Then GoTo EndOfSub
'set _Main <= string I want to look for
Dim v As String
v = "_Main"
Dim fullFilePathIWantToSet As String
'set value of fullFilePathIWantToSet from findFile function
fullFilePathIWantToSet = findFile(folderPath, v)
'when I test, this MsgBox appears, but blank
MsgBox fullFilePathIWantToSet
'If I can get this working properly, I want to be able to do something like this:
'objFSO.CopyFile fullFilePathIWantToSet, duplicateFilePath
'Presentations.Open (duplicateFilePath)
'numSlides = ActivePresentation.Slides.Count
'etc
EndOfSub:
'let the sub end
End Sub
Function findFile(ByRef folderPath As String, ByVal v As String) As String
Dim fileName As String
Dim fullFilePath As String
Dim duplicateFilePath As String
Dim numFolders As Long
Dim numSlides As Integer
Dim folders() As String, i As Long
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)
While Len(fileName) <> 0
If Left(fileName, 1) <> "." Then
fullFilePath = folderPath & fileName
duplicateFilePath = folderPath & "duplicate " & fileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve folders(0 To numFolders) As String
folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
'if true, the it matches the string we are looking for
If InStr(10, fullFilePath, v) > 0 Then
'if true, then it isn't in a dir called P/previous, which I want to avoid
If InStr(1, fullFilePath, "evious") < 1 Then
Dim objFSO As Object, f As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set f = objFSO.GetFile(fullFilePath)
'If true, then it isn't one of those funny duplicate files that microsoft makes, that has the ~ at the beginning of the file name
If f.Size > 5000 Then GoTo ReturnSettings
' if we're here then we have found the one single file that we want! Go ahead and do our thing
findFile = fullFilePath
Exit Function
End If
End If
End If
End If
fileName = Dir()
Wend
For i = 0 To numFolders - 1
findFile folders(i), v
Next i
Exit Function
ReturnSettings:
End Function
答案 1 :(得分：1)
好的，我有解决办法。它并不完全优雅，因为它依赖于全局设置的变量，但是它对我有用并且足够好：
' show if a mistake is made
Option Explicit
' globally set the var we want to return to the sub from the function
Public foundFilePath As String
Sub FindIt()
Dim colFiles As New Collection, vFile As Variant, mypath As String
FldrPicker As FileDialog, fileToFind As String, pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
mypath = .SelectedItems(1) & "\"
End With
NextCode:
mypath = mypath
If mypath = "" Then GoTo EndOf
'
' find file
'
fileToFind = "*your_string_here*"
'calls to function RecursiveDir, which sets first matching file as foundFilePath
Call RecursiveDir(colFiles, mypath, fileToFind, True)
' do what you want with foundFilePath
MsgBox "Path of file found: " & foundFilePath
'
'find second file
'
fileToFind = "*your_second_string_here*"
Call RecursiveDir(colFiles, mypath, fileToFind, True)
MsgBox "Second file path: " & foundFilePath
EndOf:
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String, fullFilePath As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
strFileSpec = Replace(strFileSpec, "*", "")
If InStr(strTemp, strFileSpec) > 0 Then
foundFilePath = strFolder & strTemp
Exit Function
End If
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
那行得通。 对我来说，更好的解决方案是 。它使用单独的子功能来执行以下操作：选择一个文件夹；遍历第一个孩子的文件夹；使用部分文件名在所有文件夹和子文件夹中递归搜索文件；对找到的文件进行处理（如果在多个字符串上调用了搜索功能，则复数）。
不必像这样分离出来，但我发现分离关注点并使事情保持简单很容易。
Sub 1：根文件夹选择器。将选定的文件夹传递到sub 2
Option Explicit
Public foundFilePath As String
Sub StartSub()
' selects the parent folder and passes it to LoopSuppliers
Dim masterPath As String, FldrPicker As FileDialog, pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
pptApp.Visible = True
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
masterPath = .SelectedItems(1) & "\"
End With
NextCode:
masterPath = masterPath
If masterPath = "" Then GoTo EndOf
Call LoopSuppliers(masterPath) ' goes to masterFolder in LoopSuppliers sub
EndOf:
End Sub
子二：只是循环浏览父文件夹，并传递每个第一个子子文件夹的路径以使函数三执行某些操作。改编自here。
Private Sub LoopSuppliers(masterFolder As String)
Dim objFSO As Object, objFolder As Object, objSupplierFolder As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(masterFolder)
For Each objSupplierFolder In objFolder.SubFolders
'objSupplierFolder.path objSubFolder.Name <- object keys I can grab
Call ManipulateFiles(objSupplierFolder.path)
Next objSupplierFolder
End Sub
功能1：抓取文件路径以进行某些操作
Private Function ManipulateFiles(ByRef FolderPath As String)
Dim file1 As String, file2 As String, file3 As String
' each of these calls find a file anywhere in a suppliers subfolders, using the second param as a search string, and then holds it as a new var
Call FindSupplierFile(FolderPath, "search_string1")
file1 = foundFilePath
Call FindSupplierFile(FolderPath, "search_string2")
file2 = foundFilePath
Call FindSupplierFile(FolderPath, "search_string3")
file3 = foundFilePath
'
' do something with the files!
'
End Function
功能2：该功能需要一个dir，一个搜索字符串，然后循环遍历所有dirs文件夹和子文件夹，直到得到匹配。我包括了额外的筛选，以显示如何进一步缩小可以返回功能1的文件的范围。
Private Function FindSupplierFile(ByRef FolderPath As String, ByVal v As String) As String
Dim FileName As String, fullFilePath As String, numFolders As Long, Folders() As String, i As Long
Dim objFSO As Object, f As Object
If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
FileName = Dir(FolderPath & "*.*", vbDirectory)
While Len(FileName) <> 0
If Left(FileName, 1) <> "." Then
fullFilePath = FolderPath & FileName
If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
ReDim Preserve Folders(0 To numFolders) As String
Folders(numFolders) = fullFilePath
numFolders = numFolders + 1
Else
'
' my filters
'
If InStr(1, fullFilePath, "evious") < 1 Then ' filter out files in folders called "_p/Previous"
If InStr(10, fullFilePath, v) > 0 Then ' match for our search string 'v'
Set objFSO = CreateObject("Scripting.FileSystemObject") ''
Set f = objFSO.GetFile(fullFilePath) '' use these three code lines to check that the file is more that 5kb - ie not a tiny ~ file
''
If f.Size > 5000 Then ''
foundFilePath = fullFilePath ' if we get in here we have the file that we want
Exit Function ' as we have found the file we want we can exit the function (which means we carry on with ManipulateFiles)
End If ' end f.size
End If ' end InStr v if
End If ' end InStr evious if
'
' end of my filters
'
End If ' end get attr if else
End If ' end left if
FileName = Dir()
Wend ' while len <> 0
For i = 0 To numFolders - 1
FindSupplierFile Folders(i), v
Next i
End Function