多用户文件夹结构差异导致VBA路径找不到问题求解

我编写的VBA代码可通过文件路径调用邮件模板，根据表格单元格内容预填充邮件，同时按单元格内的附件名称查找对应路径下的附件。本地运行正常，但推广给同事后，因各用户的访问路径存在差异：

我：G:\Group\Data\Business\Call\Excel\Email.oft
同事1：G:\Data\Business\Call\Excel\Email.oft
同事2：G:\Business\Call\Excel\Email.oft

设置固定路径会触发「Path not found」错误，尝试使用\..\无法解决，且主Excel文件通过SharePoint站点打开，无法使用ThisWorkbook.Path。目前约有20名用户，无法统计所有路径，需适配所有用户（含临时用户）的路径兼容问题。当前VBA代码如下：

Sub Send_email_fromtemplate()
Dim edress As String
Dim subj, name As String
Dim filename As String
Dim outlookapp As Object
Dim outlookmailitem As Object
Dim myAttachments As Object
Dim path As String
Dim attachment As String
Dim r As Long
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim customername As String

r = 2

Do While Sheet1.Cells(r, 1) <> ""
    Set outlookapp = CreateObject("Outlook.Application")
    'call your template
    Set outlookmailitem = outlookapp.CreateItemFromTemplate("G:\Group\Data\Business\Call\Excel\Email.oft")
    outlookmailitem.Display
    Set myAttachments = outlookmailitem.Attachments
    'deifine your path for the attachment
    path = "G:\Group\Data\Business\Call\Excel\"
    edress = Sheet1.Cells(r, 1)
    name = Sheet1.Cells(r, 2).Value
    subj = Sheet1.Cells(r, 3)
    filename = Sheet1.Cells(r, 4)
    attachment = path + filename
    With outlookmailitem
        .To = edress
        .cc = ""
        .bcc = ""
        .Subject = subj
        myAttachments.Add (attachment)
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(FindText:="{{Placeholder for Name}}")
                oRng.Text = name
                Exit Do
            Loop
        End With
        Set xInspect = outlookmailitem.GetInspector
  
       .Display
        '.send
    End With
    'clear your email address
    edress = ""
    r = r + 1
Loop
'clear your fields
Set outlookapp = Nothing
Set outlookmailitem = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub

针对路径兼容问题，推荐两种实用方案：

方案1：用户首次选择路径后自动保存（简单易用） #

让用户首次运行时手动选择模板所在文件夹，路径会自动保存到Excel的隐藏单元格中，后续运行无需再操作。此方案无需复杂逻辑，适配所有用户。

修改后的代码：

Sub Send_email_fromtemplate()
    Dim edress As String
    Dim subj As String, name As String
    Dim filename As String
    Dim outlookapp As Object
    Dim outlookmailitem As Object
    Dim myAttachments As Object
    Dim path As String
    Dim attachment As String
    Dim r As Long
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim templatePath As String
    Dim settingsName As String
    
    settingsName = "EmailTemplatePath"
    ' 尝试读取已保存的路径
    On Error Resume Next
    path = ThisWorkbook.Names(settingsName).RefersToRange.Value
    On Error GoTo 0
    
    ' 路径不存在或无效时，让用户选择
    If path = "" Or Dir(path & "Email.oft") = "" Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "请选择邮件模板所在文件夹（需包含Email.oft）"
            If .Show = -1 Then
                path = .SelectedItems(1) & "\"
                ' 保存路径到隐藏单元格
                On Error Resume Next
                ThisWorkbook.Names(settingsName).Delete
                On Error GoTo 0
                ThisWorkbook.Names.Add Name:=settingsName, RefersTo:=Range("XFD1048576")
                ThisWorkbook.Names(settingsName).RefersToRange.Value = path
                ThisWorkbook.Names(settingsName).RefersToRange.EntireRow.Hidden = True
            Else
                MsgBox "未选择路径，程序退出。"
                Exit Sub
            End If
        End With
    End If
    
    templatePath = path & "Email.oft"
    ' 验证模板文件是否存在
    If Dir(templatePath) = "" Then
        MsgBox "未找到邮件模板，请重新选择路径。"
        On Error Resume Next
        ThisWorkbook.Names(settingsName).Delete
        On Error GoTo 0
        Exit Sub
    End If
    
    r = 2
    ' 仅创建一次Outlook实例，提升运行效率
    Set outlookapp = CreateObject("Outlook.Application")
    
    Do While Sheet1.Cells(r, 1) <> ""
        Set outlookmailitem = outlookapp.CreateItemFromTemplate(templatePath)
        outlookmailitem.Display
        Set myAttachments = outlookmailitem.Attachments
        
        edress = Sheet1.Cells(r, 1)
        name = Sheet1.Cells(r, 2).Value
        subj = Sheet1.Cells(r, 3)
        filename = Sheet1.Cells(r, 4)
        attachment = path & filename
        
        With outlookmailitem
            .To = edress
            .cc = ""
            .bcc = ""
            .Subject = subj
            ' 附件存在才添加，避免报错
            If Dir(attachment) <> "" Then
                myAttachments.Add (attachment)
            Else
                MsgBox "行" & r & "的附件「" & filename & "」未找到，已跳过添加。"
            End If
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            With oRng.Find
                Do While .Execute(FindText:="{{Placeholder for Name}}")
                    oRng.Text = name
                    Exit Do
                Loop
            End With
            .Display
            '.send
        End With
        
        edress = ""
        r = r + 1
        ' 释放当前邮件对象
        Set outlookmailitem = Nothing
        Set myAttachments = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
    Loop
    
    Set outlookapp = Nothing
    MsgBox "邮件处理完成。"
End Sub

方案2：自动搜索模板路径（无需用户操作） #

通过遍历本地驱动器，搜索包含Email.oft的目标子路径，自动定位模板位置。适合不想让用户手动操作的场景。

搜索函数代码 #

' 搜索目标文件的路径，遍历驱动器查找匹配的子路径
Function FindFilePath(targetFileName As String, commonSubPath As String) As String
    Dim driveLetters As Variant
    Dim drive As Variant
    Dim searchPath As String
    Dim tempPath As String
    
    ' 遍历常见驱动器
    driveLetters = Split("C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", ",")
    
    For Each drive In driveLetters
        ' 尝试完整子路径
        searchPath = drive & ":\" & commonSubPath
        tempPath = searchPath & targetFileName
        If Dir(tempPath) <> "" Then
            FindFilePath = searchPath
            Exit Function
        End If
        ' 尝试去掉一级父目录（如Group\）
        searchPath = drive & ":\" & Mid(commonSubPath, InStr(commonSubPath, "\") + 1)
        tempPath = searchPath & targetFileName
        If Dir(tempPath) <> "" Then
            FindFilePath = searchPath
            Exit Function
        End If
        ' 尝试再去掉一级父目录（如Data\）
        searchPath = drive & ":\" & Mid(searchPath, InStr(searchPath, "\") + 1)
        tempPath = searchPath & targetFileName
        If Dir(tempPath) <> "" Then
            FindFilePath = searchPath
            Exit Function
        End If
    Next drive
    
    ' 未找到返回空
    FindFilePath = ""
End Function

主代码中调用搜索函数 #

在原代码开头添加以下逻辑替换固定路径：

Dim path As String
Dim templatePath As String

' 搜索模板路径
path = FindFilePath("Email.oft", "Group\Data\Business\Call\Excel\")
If path = "" Then
    MsgBox "未找到邮件模板，请确认模板所在驱动器后重试。"
    Exit Sub
End If
templatePath = path & "Email.oft"

内容的提问来源于stack exchange，提问作者Yool