Excel vba：范围到邮件正文 – 超链接剪切
我正在使用一个修改后的Ron De Bruin的代码来调用一个带有范围的表格的Outlook邮件窗口。 在这个范围内，有一些细胞在我们公司的共同点上包含链接。 当创build的表格被插入到邮件正文中时，单元格中的超链接从一开始就以某种方式缩短，所以地址开始简单地带有两个点（字面意思）。 我想知道是否可以修改该function，以保持整个链接的地址，或者在邮件正文中插入表格之后，地址中的“..”可以通过地址的常规开始移除，这总是相同的？
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，并且每次都可以预测，那么您可以在函数中添加一个Replace ，以将正确的值放回。您可能需要确保不要在身体其他地方使用。 如果你这样做，你需要做别的事情。
所以在现有的线路之后：
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=")
添加以下行：
RangetoHTML = Replace(RangetoHTML, "..", _ "http:\\the missing part of the link etc")