Finding a file name from selected partial text

user_17688087 0
Viewed 379

I grabbed someone else's code and tried multiple different functions to make it fit my needs.

I use a Word document for PLC reports. I'm trying to take selected text (like a station number, BM150 for example), and find a file from the partial text within any subfolder from the designated path and then hyperlink to it.

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

This works if I type the exact file name and exact file path but I only input part of the file name in the report, and I want it to search multiple subfolders.

ms-word vba
2 Answers

Find File Using a Partial File Name

  • Uses the function to return all matching file paths in an array and creates a hyperlink to the first matching file.
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
user_98140690

Here is a code to get a list of files in folder (the path to search): FilesInFolderAndSubfolders return array of filenames.

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
user_29239340
Related