Excel vba:邮件正文的范围-超链接剪切

我使用修改过的Ron De Bruin代码调用outlook邮件窗口，其中包含一个由range生成的表。在这个范围内，有一些单元格包含我们公司sharepoint上的链接。当创建的表插入邮件正文时，单元格中的超链接从一开始就以某种方式缩短，因此地址从字面上的两点开始。我想知道是否可以修改该函数以保留整个链接地址，或者在邮件正文中插入表之后。。在地址中，可以通过地址的常规开头来删除，这始终是相同的

Sub create_mail()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng      As Range
    Dim OutApp   As Object
    Dim OutMail  As Object
    Dim lastrow  As Long
    Dim today    As Date
    Dim copies   As String
    Dim cell    As Range

'    get names of "responsible persons" to receive a copy
    lastrow = Range("b" & Rows.Count).End(xlUp).Row
    For Each cell In Range("g2:g" & lastrow)
        copies = copies & cell.Value & ";"
        Next cell


'    Create borders around the table
    Set rng = Range("a1:j" & lastrow)
    With rng.Borders
            .LineStyle = xlContinuous
            .Color = vbBlack
            .Weight = xlThin
            End With

'    macro will work faster
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

'    save the file on sharepoint
    ActiveWorkbook.SaveAs Filename:= _
        "sharepoint_adress" & Format(Date, "mmddyyyy") & "_Agenda.xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

'create a mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "yo mama"
        .CC = copies
        .BCC = ""
        .Subject = "blah blah blah " & Format(Date, "mmddyyyy")
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteAll, , False, False
        .Cells(1).PasteSpecial xlPasteAll, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

如果。。是通过删除每次都相同且可以预测的URL部分来缩短URL，然后您可以在函数中再添加一个替换，以重新输入正确的值。您可能希望确保不使用。。当然在身体的其他地方。如果你这样做了，你需要做些别的事情

因此，在既有线路之后：

RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

添加以下行：

RangetoHTML = Replace(RangetoHTML, "..", _
                      "http:\\the missing part of the link etc")