2 如何填充 Outlook sendmail 超链接地址并保存为工作表，以便在发送的电子邮件中单击超链接时，它会打开保存的工作表或文件夹

Question

下面是我的原始代码，当在 Excel 中运行时，它会保存活动文档的副本并发送附有所述文档的电子邮件。下面的电子邮件代码当前包含指向通用文件夹的超链接。超链接的问题在于，它当前特定于该行代码中“硬”键入的地址，我希望通过以下两种方式之一自定义填充超链接。

更新：问题已通过代码解决，如下面两个选项所示。

第一个也是首选选项是创建一个超链接，直接打开已保存的文件（不是附加文件）。 代码是 这里。

第二个选项是一个超链接，可打开已保存文件（非附加文件）所在的实际文件夹。 代码是 这里。

以下是原代码

'Establish file name and save location using data from Form

    Dim MyFile, MyFileDest, MyFileName As String
    
    MyFile = ActiveSheet.Range("B5").Value & " " & ActiveSheet.Range("F5").Value & " " & ActiveSheet.Range("E5").Value & " (" & ActiveSheet.Range("AB8").Value & ")" & ".xlsm"
    MyFileDest = "\\camawsis03\Team Center\" & ActiveSheet.Range("B5").Value & "\" & ActiveSheet.Range("B5").Value & " " & "Rework Forms\"
    MyFileName = MyFileDest & MyFile
    
'Check if folder exist, if not create folder

    If Dir(MyFileDest, vbDirectory) <> vbNullString Then
    'MsgBox "Folder exists"
    Else
    
    MkDir "\\camawsis03\Team Center\" & ActiveSheet.Range("B5").Value & "\" & ActiveSheet.Range("B5").Value & " " & "Rework Forms"
    End If


'Save to location and include pop-up Save As window

    Dim NewName As Variant
    Dim fileSaveName As Variant
    
    NewName = MyFileName
    fileSaveName = Application.GetSaveAsFilename(InitialFileName:=NewName, fileFilter:="Excel Files (*.xlsm), *.xlsm")

    If fileSaveName <> False Then
    ActiveWorkbook.SaveAs fileSaveName
    'MsgBox "File saved to: " & fileSaveName
    End If

    
'Email with attached workbook.

    Set OutlookApp = CreateObject("Outlook.Application")
    Set SendMail = OutlookApp.CreateItem(0)
    Dim JobDesc As String
    Dim Rootcause As String
    JobDesc = ActiveSheet.Range("B5").Value & " " & ActiveSheet.Range("F5").Value & " " & ActiveSheet.Range("E5").Value
    Rootcause = ActiveSheet.Range("N5").Value & " - " & ActiveSheet.Range("N6").Value & " - " & ActiveSheet.Range("N7").Value
    
    SourceFile = ThisWorkbook.FullName
    SendMail.Attachments.Add SourceFile

    SendMail.Subject = ActiveSheet.Range("B5").Value & " " & ActiveSheet.Range("F5").Value & " " & ActiveSheet.Range("E5").Value & " " & "Rework" & " " & "(" & ActiveSheet.Range("AB8").Value & ")"
    SendMail.To = Leaderemail & ";" & ActiveSheet.Range("AC5").Value
    SendMail.CC = ActiveSheet.Range("AC6").Value & "; [email protected]>"
    'Use SendMail.htmlBody for bold,unbold <b>,</b>= & new line=<br>
    SendMail.htmlBody = "Please find attached Rework Form for " & JobDesc & "." & " " & "Steel is located in" & " " & ActiveSheet.Range("E7").Value & "." & "<br><br>" _
    & vbCrLf & vbCrLf & WorkReqdComment & "<br><br>" _
    & vbCrLf & vbCrLf & PrepReqdComment & "<br><br>" _
    & vbCrLf & vbCrLf & "The attached is for notification only. Please reference master saved <a href=""\\camawsis03\Team Center\Rework Forms"">here.</a>"
    
    SendMail.Display 'displays email window
    'Use SendMail.Send to send without display.
    
    With Application
    .EnableEvents = True
    .ScreenUpdating = True
    End With
    
    Set SendMail = Nothing
    Set OutlookApp = Nothing
    
    ActiveWorkbook.Close savechanges:=False

End Sub

Answer 1

这应该有效：

SendMail.htmlBody = "Please find attached Rework Form for " & _
     JobDesc & "." & " " & "Steel is located in" & " " & _
     ActiveSheet.Range("E7").Value & "." & "<br><br>" _
    & vbCrLf & vbCrLf & WorkReqdComment & "<br><br>" _
    & vbCrLf & vbCrLf & PrepReqdComment & "<br><br>" _
    & vbCrLf & vbCrLf & "The attached is for notification only. " _
    & "Please reference master saved <a href='file:" & fileSaveName  & "'>here.</a>"