AW: VBA - Formatierung beim Kopieren
08.05.2019 12:44:25
Luschi
Hallo Thaini,
ich habe PeterK's Code auch getestet und für gut befunden; habe aber noch ein paar Feinheiten _
korrigiert (darunter natürlich den Blattschutz)
Private Sub CommandButton1_Click()
Dim objOL As Object, objMail As Object
Dim rng As Range, sHtml As String
On Error Resume Next
Set objOL = GetObject(, "OUTLOOK.Application")
If objOL Is Nothing Then
Set objOL = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If Not objOL Is Nothing Then
Set objMail = objOL.CreateItem(0)
Set rng = Sheets("Beispiel").Range("B3:I15").SpecialCells(xlCellTypeVisible)
With objMail
' --- Signatur retten ---
.BodyFormat = 2 'olFormatHTML
.GetInspector
sHtml = .HtmlBody
.To = "test@info.de"
.Subject = "Betreff"
'Signatur dranhängen
.HtmlBody = RangetoHTML(rng) & "
" & sHtml
.Display
End With
Else
MsgBox "Auf diesem PC/Notebook ist kein Outlook installiert!", _
vbMsgBoxSetForeground + 16, "zur Information..."
End If
Set objOL = Nothing: Set objMail = Nothing: Set rng = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim PO As PublishObject
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
For Each PO In ActiveWorkbook.PublishObjects
PO.Delete
Next PO
rng.Select
rng.Parent.Unprotect "Hase"
Set PO = ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:="Beispiel", _
Source:=rng.Address, _
HtmlType:=xlHtmlStatic, _
DivID:="Test")
PO.AutoRepublish = False
PO.Publish (True)
rng.Parent.Protect "Hase"
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=")
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set PO = Nothing
End Function
Gruß von Luschi
aus klein-Paris
