超鏈接無法使用範圍HTML功能

Question

使用一些VBA抓取信息表並粘貼到使用範圍到HTML的電子郵件的正文。問題似乎與超鏈接有關，因爲該功能只是將其作爲文本抓取並相應地進行格式化。我使用的VBA是：

使用.Cells(1).PasteSpecial xlPasteAll, , False, False

，而不是線.Cells(1).PasteSpecial xlPastevalues, , False, False

功能：

Sub Archive_Send() 

    Dim rng As Range 
    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim rngTo As Range 
    Dim rngSubject As Range 
    Dim rngBody1 As Range 
    Dim StrBody As String 
    Dim StrBody1 As String 

    Set rng = Nothing 
    On Error Resume Next 

    Set rng = Sheets("Posting").Range("B5:C55").SpecialCells(xlCellTypeVisible) 

    On Error GoTo 0 

    If rng Is Nothing Then 
     MsgBox "The selection is not a range or the sheet is protected" & _ 
       vbNewLine & "please correct and try again.", vbOKOnly 
     Exit Sub 
    End If 

    With Application 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    Set OutApp = CreateObject("Outlook.Application") 
    Set OutMail = OutApp.CreateItem(0) 
    Set rngTo = Sheets("Email").Range("C5") 
    Set rngSubject = Sheets("Email").Range("C3") 
    Set rngBody1 = Sheets("Email").Range("C13") 

    On Error Resume Next 
    With OutMail 
     .To = rngTo.Value 
     .Subject = rngSubject.Value 
     .HTMLBody = .HTMLBody & rngBody1.Value & "" _ 
     & RangetoHTML(rng) _ 
     & "<br><br>Best Regards,<br><br></font></span>" 
     .Display 
    End With 
    On Error GoTo 0 

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

    Set OutMail = Nothing 
    Set OutApp = Nothing 

    Application.ReferenceStyle = xlA1 
End Sub 

Function RangetoHTML(rng As Range) 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 

    Dim fso As Object 
    Dim ts As Object 
    Dim TempFile As String 
    Dim TempWB As Workbook 

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

    rng.Copy 
    Set TempWB = Workbooks.Add(1) 
    With TempWB.Sheets(1) 
     .Cells(1).PasteSpecial Paste:=8 
     .Cells(1).PasteSpecial xlPasteValues, , False, False 
     .Cells(1).PasteSpecial xlPasteFormats, , False, False 
     .Cells(1).Select 
     Application.CutCopyMode = False 
     On Error Resume Next 
     .DrawingObjects.Visible = True 
     On Error GoTo 0 
    End With 

    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 

    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=") 

    TempWB.Close SaveChanges:=False 

    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 
    Set TempWB = Nothing 

End Function 

Answer 1

代碼rangetohtml只是做如下變化不大後對我的作品有超鏈接改寫如下：

Function RangetoHTML(rng As Range) 

     Application.ScreenUpdating = False 
     Application.DisplayAlerts = False 

     Dim fso As Object 
     Dim ts As Object 
     Dim TempFile As String 
     Dim TempWB As Workbook 

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

     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 xlPasteFormats, , False, False 
      .Cells(1).Select 
      Application.CutCopyMode = False 
      On Error Resume Next 
      .DrawingObjects.Visible = True 
      On Error GoTo 0 
     End With 

     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 

     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=") 

     TempWB.Close SaveChanges:=False 

     Kill TempFile 

     Set ts = Nothing 
     Set fso = Nothing 
     Set TempWB = Nothing 

    End Function 

讓我知道這是否解決您的擔憂。 :)