Powerpoint VBA 函数返回不起作用

Question

这让我发疯：我在 powerpoint vba 中有一个 sub 和一个函数。

sub 首先允许我选择一个目录。从 sub 调用的函数在 dir 中找到一个文件。我希望它作为 sub 之外的功能，因为我需要多次使用它。

sub 仍在开发中，所以做的不多，但可以工作。如果我给它做点什么，该函数也可以工作——比如打开找到的文件（即在下面的代码中取消注释该行）——但我不能终生让它将 filePath 返回给 sub。请帮忙！

子：

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

功能：

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
    Dim i As Long

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    ileName = 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

                        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     
        End If

        fileName = Dir()

    Wend

    For i = 0 To numFolders - 1

        findFile folders(i), v

    Next i

End Function

我完全是 VBA 菜鸟，所以刚刚 pva 从我可以在网上找到的东西把它粘在一起。它是否因为 findFile 循环返回一个数组而不是字符串而不起作用？我认为“退出函数”调用会解决这个问题。

请原谅递归的 if 语句 - 我正在这样做的人没有完全标准的方式来存储他们的 ppt，但这会磨练我想要的 ppt。当 sub 完成后，它本身会循环遍历所选目录的 130 个子目录，并且在每个子目录中，它将从六个不同的 ppts 中抓取各种幻灯片并将它们合并为一个，即将 780 ppts 中的数据合并为 130 -我绝对想自动化的东西！

这是我在堆栈溢出上发布的第一个问题，所以我希望我已经清楚正确地提出了它。我已经广泛搜索了这个问题的解决方案。我希望解决方案弹出给你！非常感谢。

Answer 1

这是一个需要使用Option Explicit的经典案例。

您缺少来自filename 的f，并且它作为变量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

Answer 2

好的，我有办法解决这个问题。它并不完全优雅，因为它依赖于全局设置的变量，但它可以工作并且对我来说已经足够好了：

' 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