Range per Mail versenden - Hyperlinks beibehalten

  • Excel

Es gibt 1 Antwort in diesem Thema. Der letzte Beitrag () ist von volti.

    Range per Mail versenden - Hyperlinks beibehalten

    Hallo,

    ich hatte vor mit einem Button und einem hinterlegten VBA Code einen ausgewählten Bereich ins Outlook zu kopieren.
    Mailadressen sind je nach Anwendungsfall spezifisch.
    Die Formatierung bleibt mir mit dieser Variante von Ron de Bruin nun endlich erhalten, jedoch verlieren sich dabei die noch Hyperlinks (welche spezifisch und niemals dieselben sind), die ich aber in jedem Fall benötige.
    Weiß jemand eine bessere Lösung, wo eine Änderung nötig ist bzw. wie das gelöst werden könnte?
    Die aktuelle Umsetzung war ein einfaches Strg+C im Excel und Strg+V in der neuen E-Mail, da möchte ich weg kommen...

    Quellcode

    1. Sub Mail_Selection_Range_Outlook_Body()
    3. Dim teilenummer As String
    4. teilenummer = ActiveSheet.Cells(1, 1).Value
    5. Dim rng As Range
    6. Dim OutApp As Object
    7. Dim OutMail As Object
    9. Set rng = Nothing
    10. On Error Resume Next
    11. Set rng = Selection.SpecialCells(xlCellTypeVisible)
    13. On Error GoTo 0
    15. If rng Is Nothing Then
    16. MsgBox "The selection is not a range or the sheet is protected" & _
    17. vbNewLine & "please correct and try again.", vbOKOnly
    18. Exit Sub
    19. End If
    21. With Application
    22. .EnableEvents = False
    23. .ScreenUpdating = False
    24. End With
    26. Set OutApp = CreateObject("Outlook.Application")
    27. Set OutMail = OutApp.CreateItem(0)
    29. On Error Resume Next
    30. With OutMail
    31. .To = ""
    32. .CC = ""
    33. .BCC = ""
    34. .Subject = "Q-Status für " & teilenummer
    35. .HTMLBody = RangetoHTML(rng)
    36. .Display
    37. End With
    38. On Error GoTo 0
    40. With Application
    41. .EnableEvents = True
    42. .ScreenUpdating = True
    43. End With
    45. Set OutMail = Nothing
    46. Set OutApp = Nothing
    47. End Sub
    49. Function RangetoHTML(rng As Range)
    51. Dim fso As Object
    52. Dim ts As Object
    53. Dim TempFile As String
    54. Dim TempWB As Workbook
    56. TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    58. rng.Copy
    59. Set TempWB = Workbooks.Add(1)
    60. With TempWB.Sheets(1)
    61. .Cells(1).PasteSpecial Paste:=8
    62. .Cells(1).PasteSpecial xlPasteValues, , False, False
    63. .Cells(1).PasteSpecial xlPasteFormats, , False, False
    64. .Cells(1).Select
    65. Application.CutCopyMode = False
    66. On Error Resume Next
    67. .DrawingObjects.Visible = True
    68. .DrawingObjects.Delete
    69. On Error GoTo 0
    70. End With
    72. With TempWB.PublishObjects.Add( _
    73. SourceType:=xlSourceRange, _
    74. Filename:=TempFile, _
    75. Sheet:=TempWB.Sheets(1).Name, _
    76. Source:=TempWB.Sheets(1).UsedRange.Address, _
    77. HtmlType:=xlHtmlStatic)
    78. .Publish (True)
    79. End With
    81. Set fso = CreateObject("Scripting.FileSystemObject")
    82. Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    83. RangetoHTML = ts.readall
    84. ts.Close
    85. RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    86. "align=left x:publishsource=")
    88. TempWB.Close savechanges:=False
    90. Kill TempFile
    92. Set ts = Nothing
    93. Set fso = Nothing
    94. Set TempWB = Nothing
    95. End Function

    Hallo,

    lass das RangeToHTML-Geraffel weg und kopiere den Bereich über den Word-Editor.

    Hier Dein angepasster Code und ein weiteres Beispiel mit zusätzlichem Text und Signatur....

    VB.NET-Quellcode

    1. Sub Mail_Selection_Range_Outlook_Body()
    2. Dim teilenummer As String
    4. teilenummer = ActiveSheet.Cells(1, 1).Value
    5. Dim rng As Range
    6. Dim OutApp As Object
    7. Dim OutMail As Object
    9. Set rng = Nothing
    10. On Error Resume Next
    11. Set rng = Selection.SpecialCells(xlCellTypeVisible)
    12. On Error GoTo 0
    13. If rng Is Nothing Then
    14. MsgBox "The selection is not a range or the sheet is protected" & _
    15. vbNewLine & "please correct and try again.", vbOKOnly
    16. Exit Sub
    17. End If
    18. With Application
    19. .EnableEvents = False
    20. .ScreenUpdating = False
    21. End With
    22. Set OutApp = CreateObject("Outlook.Application")
    23. Set OutMail = OutApp.CreateItem(0)
    24. On Error Resume Next
    25. With OutMail
    26. .To = ""
    27. .CC = ""
    28. .BCC = ""
    29. .Subject = "Q-Status für " & teilenummer
    30. .Display
    31. rng.Copy
    32. .GetInspector.WordEditor.Range.Paste ' Bereich in Mail einfügen
    33. End With
    34. On Error GoTo 0
    35. With Application
    36. .EnableEvents = True
    37. .ScreenUpdating = True
    38. End With
    39. Set OutMail = Nothing
    40. Set OutApp = Nothing
    41. End Sub
    43. Private Sub Mail_BereichalsBereich_Word1()
    44. ' Sendet Mail mit integriertem Bereich als Bereich mit Signatur
    45. Dim WSh1 As Worksheet, WSh2 As Worksheet
    46. Dim sMailtext As String, sBer As String
    48. sBer = "AS1:AV12" ' Kopierbereich
    49. Set WSh1 = ThisWorkbook.Sheets("Tabelle1") ' Blatt mit Maildaten
    50. Set WSh2 = ThisWorkbook.Sheets("Tabelle2") ' Datenblatt
    52. WSh2.Range(sBer).Copy ' Bereich kopieren
    54. With CreateObject("Outlook.Application").CreateItem(0)
    55. .BodyFormat = 2 ' 2=HTML-Format, 3=Richtext
    56. .Subject = WSh1.Range("A2").Value ' Betreff
    57. .To = WSh1.Range("A3").Value ' Empfänger
    58. .CC = WSh1.Range("A4").Value ' Kopie
    59. sMailtext = WSh1.Range("A5").Value & vbLf
    60. .GetInspector ' Signatur holen
    61. .htmlbody = Replace(sMailtext, vbLf, "<br>") & .htmlbody
    62. .Display
    64. With .GetInspector.WordEditor.Application.Selection
    65. .start = Len(sMailtext) + 1
    66. .Paste ' Bereich in Mail einfügen
    67. End With
    69. End With
    71. End Sub


    Gruß
    Karl-Heinz

Facebook
Telefonspende