Tabelle in eMail kopieren mit Formatierung via VBA
26.04.2014 17:47:59
Sebastian
ich habe eine Tabelle, die ich filtern lasse und dann eine bestimmte Mail per eMail versenden möchte.
Ich möchte die Tabelle jedoch in der selben Formatierung via eMail einbinden, wie sie auch in Excel ist, das gelingt mir aktuell jedoch noch nicht.
Es wird wohl an den Eigenschaften von xlpaste liegen, allerdings kriege ich es nicht hin :(
Hier ist mein Code:
Private Sub CommandButton2_Click()
Dim eMail As Variant
eMail = Sheets("Tabelle1").Cells(2, 10)
Dim rng As Range
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Set rng = Nothing
On Error Resume Next 'Only the visible cells in the selection
Set rng = Sheets("Tabelle1").Range("B4:N500").SpecialCells(xlCellTypeVisible) 'Hier den _
Bereich der gesamten Tabelle angeben
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Die Auswahl ist kein Bereich oder das Tabellenblatt ist geschützt.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With OutMail
.To = eMail
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.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
Der Code der Function:
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"
'Copy the range and create a new workbook to past the data in
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
'Publish the sheet to a htm file
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
'Read all data from the htm file into RangetoHTML
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=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
