我需要 VBA 帮助以从部分选定文本中查找完整文件名

Question

我几乎没有使用 VBA 的经验，最近尝试开始学习和学习它。我抓住了别人的代码，并尝试了多种不同的功能来满足我的需求，但我遇到了问题。在工作中，我们经常为 PLC 报告使用 word 文档，我正在尝试制作一个宏，它将采用选定的文本（如站号，例如 BM150），并从任意文本中的部分文本中找到一个文件从指定路径创建子文件夹，然后超链接到它。

Sub HLink_Selected_Text()
Dim strPath As String
Dim StrSelection As Range
Dim sName As String
Dim fs As String

strPath = "filepath" 'the path to search

    Set StrSelection = Selection.Range
    sName = Dir$(strPath & Trim(StrSelection.Text) & ".*") 'change extension to ".*") for any file
    fs = strPath & sName
    If Not sName = "" Then
        StrSelection.Hyperlinks.Add Anchor:=StrSelection, Address:=fs, TextToDisplay:=Trim(StrSelection.Text)
    Else
        MsgBox "Matching document not found"
    End If
End Sub

如果我输入 EXACT 文件名和 EXACT 文件路径，但我们只在报告中输入文件名的一部分，并且我希望它搜索多个子文件夹，则此代码非常有效。任何帮助将不胜感激。

Answer 1

这是获取文件夹中文件列表的代码（搜索路径）： FilesInFolderAndSubfolders 返回文件名数组。

Private Function FilesInFolderAndSubfolders(ByVal folderspec As String) As String()
    Dim arrFiles() As String
    Dim fso As Object   'file system object
    Dim currentFolder   'current folder in file system object
    Dim subFolder       'every subfolder
    
    'creating file system object
    Set fso = CreateObject("Scripting.FilesystemObject")
    
    Set currentFolder = fso.GetFolder(folderspec)   'get currentdirectory object
    
    'file list in current path
    FilesInFolder fso, folderspec, arrFiles
    
    'files lists in subfolders
    For Each subFolder In currentFolder.SubFolders
        FilesInFolder fso, subFolder.Path, arrFiles
    Next subFolder
    
    Set fso = Nothing
    Set currentFolder = Nothing
    Set subFolder = Nothing
    
    FilesInFolderAndSubfolders = arrFiles

End Function


Private Sub FilesInFolder(ByRef fso As Object, ByVal folderPath As String, ByRef arrFiles() As String)
    Dim currentFolder
    Dim file
    
    Set currentFolder = fso.GetFolder(folderPath)
    
    For Each file In currentFolder.files
        If Not Not arrFiles() Then 'if table exist
            ReDim Preserve arrFiles(LBound(arrFiles) To UBound(arrFiles) + 1)
        Else
            ReDim arrFiles(0)
        End If
        arrFiles(UBound(arrFiles)) = folderPath & "\" & file.Name
    Next file

    Set file = Nothing
    Set currentFolder = Nothing
End Sub

Answer 2

使用部分文件名查找文件

• 使用该函数以数组形式返回所有匹配的文件路径，并创建指向第一个匹配文件的超链接。

Option Explicit

Sub HLink_Selected_Text_Word()
    
    Const FolderPath As String = "C:\Test"  'the path to search
    
    Dim strSelection As Range: Set strSelection = Selection.Range
    Dim Partial As String: Partial = Trim(strSelection.Text)
    Dim FilePattern As String: FilePattern = "*" & Partial & "*.*" ' contains
    'FilePattern = Partial & "*.*" ' begins with
    'FilePattern = "*" & Partial & ".*" ' ends with
    
    Dim FilePaths As Variant: FilePaths = ArrFilePaths(FolderPath, FilePattern)
    Dim fUpper As Long: fUpper = UBound(FilePaths)
    
    Dim fPath As String
    Dim fName As String
    
    If fUpper >= 0 Then ' there could be multiple matches
        fPath = FilePaths(0) ' using the first match '(0)'
        fName = Dir(FilePaths(0))
        strSelection.Hyperlinks.Add Anchor:=strSelection, Address:=fPath, _
            TextToDisplay:=Partial
        If fUpper > 0 Then
            MsgBox "Matching documents found: " & fUpper + 1 & vbLf _
                & Join(FilePaths), vbExclamation
        End If
    Else
        MsgBox "Matching document not found"
    End If
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the file paths of the files in a folder in an array.
'               'b'   - to get file paths (e.g. 'C:\Test\Test.txt')
'               's'   - to search in subfolders
'               'a-d' - to exclude directories (folders)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*", _
    Optional ByVal DirSwitches As String = "/s/b/a-d") _
As Variant
    Const ProcName As String = "ArrFilePaths"
    On Error GoTo ClearError
    
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    ArrFilePaths = Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf)

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function