Question

使用一些VBA获取信息表并使用范围到html粘贴到电子邮件正文。问题似乎是超链接，因为该功能只是将其作为文本抓取并相应地格式化。我正在使用的vba是：

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在我做了很少的更改后立即使用超链接：

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

而非行.Cells(1).PasteSpecial xlPastevalues, , False, False

使用以下所述更改重写函数：

    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

如果这解决了您的问题，请告诉我。：）

超链接无法使用Range到HTML功能

1 个答案: