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...
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
- Sub Mail_Selection_Range_Outlook_Body()
- Dim teilenummer As String
- teilenummer = ActiveSheet.Cells(1, 1).Value
- Dim rng As Range
- Dim OutApp As Object
- Dim OutMail As Object
- Set rng = Nothing
- On Error Resume Next
- Set rng = Selection.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)
- On Error Resume Next
- With OutMail
- .To = ""
- .CC = ""
- .BCC = ""
- .Subject = "Q-Status für " & teilenummer
- .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)
- 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"
- 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
- .DrawingObjects.Delete
- 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