Mail Makro: Tabelle in html text einfügen

Hallo,
ich habe folgendes Problem: Ich habe ein Mailmakro, das eine neue Mail öffnet und entsprechend mit Text und Empfänger usw. füttert. Ich möchte allerdings nun in den HTMLBody (siehe angehängtes makro) eine kleine Tabelle aus Excel einfügen. Und zwar soll die kleine Tabelle zwischen strText und grussformel. Geht das? Kann mir bitte jemand von euch weiterhelfen?
Danke :)
Gruß, Peter
Sub Makro_Generate_Mail()
Dim objOut As Object
Dim objMail As Object
Dim strText As String
Dim Operator As String
Dim grussformel As String
Set objOut = CreateObject("Outlook.Application")
Set objMail = objOut.CreateItem(olMailItem)
strText = Tabelle1.Shapes("Textfeld 1").TextFrame2.TextRange.Text
grussformel = Tabelle1.Shapes("Textfeld 3").TextFrame2.TextRange.Text
Operator = Range("A3").Value
With objMail
'EMail-Parameter festlegen (Betreff, Empfänger, Text)
.Subject = "123456789"
.Body = strText
.BodyFormat = 2
.HTMLBody = "Hi Heiko," & "
" & "
" & "" & "" & strText & "
" & "
" & grussformel
.To = Worksheets("Result").Range("A3").Value & "@gerhardschroeder.com"
.cc = "Angela.merkel@cdumail.com" & ";" & Worksheets("Result").Range("A3").Value & "@helmutkohl.com"
'Zeigt die EMail unabgesendet im Fenster an
.Display
'.Send (optional)
'Cursor ans Ende der EMail setzen
VBA.SendKeys "^{END}", True

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Makro_Generate_Mail() Dim objOut As Object Dim objMail As Object Dim strText As String Dim Operator As String Dim grussformel As String Set objOut = CreateObject("Outlook.Application") Set objMail = objOut.CreateItem(olMailItem) Set ClpObj = New DataObject strText = Tabelle1.Shapes("Textfeld 1").TextFrame2.TextRange.text grussformel = Tabelle1.Shapes("Textfeld 3").TextFrame2.TextRange.text Operator = Range("A3").value With objMail 'EMail-Parameter festlegen (Betreff, Empfänger, Text) .Subject = "123456789" .Body = strText '.BodyFormat = 2 Range("A1:B5").Copy 'hier deinen Bereich, eventuell auch Blattname noch angeben ClpObj.GetFromClipboard .HTMLBody = "Hi Heiko," & "" " & "" & "" & strText & " " & ClpObj.GetText(1) & grussformel '.To = Worksheets("Result").Range("A3").value & "@gerhardschroeder.com" '.CC = "Angela.merkel@cdumail.com" & ";" & Worksheets("Result").Range("A3").value & "@ _ helmutkohl.com" 'Zeigt die EMail unabgesendet im Fenster an .Display '.Send (optional) 'Cursor ans Ende der EMail setzen VBA.SendKeys "^{END}", True

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

Sub Makro_Generate_Mail() Dim objOut As Object Dim objMail As Object Dim strText As String Dim Operator As String Dim grussformel As String Dim rng As Range Set objOut = CreateObject("Outlook.Application") Set objMail = objOut.CreateItem(olMailItem) Set rng = Sheets("Sheet1").Range("A1:B5") strText = Tabelle1.Shapes("Textfeld 1").TextFrame2.TextRange.text grussformel = Tabelle1.Shapes("Textfeld 3").TextFrame2.TextRange.text Operator = Range("A3").value With objMail 'EMail-Parameter festlegen (Betreff, Empfänger, Text) .Subject = "123456789" .Body = strText .BodyFormat = 2 .HTMLBody = "Hi Heiko," & "" " & "" & "" & strText & " " & rangetoHTML(rng) & grussformel .To = Worksheets("Result").Range("A3").value & "@gerhardschroeder.com" .CC = "Angela.merkel@cdumail.com" & ";" & Worksheets("Result").Range("A3").value & "@helmutkohl. _ com" 'Zeigt die EMail unabgesendet im Fenster an .Display '.Send (optional) 'Cursor ans Ende der EMail setzen VBA.SendKeys "^{END}", True

Guten Morgen!
Versuch mal folgendes:
Hier wird die Tabelle aus den einzelnen Feldern der Tabelle neu aufgebaut.
Leider mußte ich die Zeichen für kleinergleich und größérgleich durch das Wort ersetzen, weil sonst dieses Eingabeformular die html-Befehle sofort umsetzt und sie für dich nicht mehr sichtbar sind.

Sub Html_test_ausführen()
Dim titel As String, text As String, html_tab As String, html_kompl As String
Dim test As Boolean
test = False
titel = Now
text = "Dies ist eine automatische Nachricht aus der Fehlerstatistik- _
TabellekleinergleichbrgrößergleichFolgende Positionen sind als erwarteter WE gekennzeichnet, jedoch noch nicht eingetroffen:"
html_tab = html_tab_text(2, 4, "1;2;sehr langer Text;4", "A;B;C;D;E;F;G;H")
html_kompl = html_aufbau(titel, text, html_tab, test)
Dim MyMessage As Object, MyOutApp As Object
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = send_to
.cc = Kopie_an
.Subject = Betreff
.DeleteAfterSubmit = del_gesendet
.HTMLBody = text
End With
End Sub
Function html_aufbau(titel As String, htm_txt As String, Optional tab_text As String, Optional  _
test As Boolean)
Dim a, B, C, D, E, F, G, H
Dim kopf As String, körper As String
a = "" '"kleinergleichmeta charset=""utf-8""größergleichkleinergleichstylegrößergleichtable, _
td, th { border: 1px solid black; }kleinergleich/stylegrößergleich"
B = "kleinergleichtitlegrößergleich" & titel & "kleinergleich/titlegrößergleich" 'Titel des  _
Tabellenreiters
C = "kleinergleich h1 style='background:#BFBFBF'größergleich" & titel & "kleinergleich/h1grö _
ßergleich" 'Überschrift
D = htm_txt & "kleinergleichbrgrößergleichkleinergleichbrgrößergleichkleinergleichbrgröß _
ergleich"
kopf = "kleinergleichheadgrößergleich" & a & B & "kleinergleich/headgrößergleich"
körper = "kleinergleichbodygrößergleich" & C & D & tab_text & "kleinergleich/bodygröß _
ergleich"
html_aufbau = html_text_generieren("kleinergleichhtmlgrößergleich" & kopf & körper & " _
kleinergleich/htmlgrößergleich", test)
End Function
Function html_tab_text(z_zahl As Long, sp_zahl As Long, Ü_schr_text As String, tab_text As  _
String)
'Fügt eine Tabelle mit Inhalt in einen Text für eine email ein.
'Felder müssen Zeilenweise mit kommas getrennt sein
Dim txt_arr As Variant, Ü_schr_arr As Variant
Dim zähl As Long, zeil As Long, spalt As Long
Dim txt As String, style_tmp As String
Ü_schr_arr = Split(Ü_schr_text, ";")
txt_arr = Split(tab_text, ";")
zähl = 0
'Kopfzeile
style_tmp = "style='width:130.5pt;background:#BFBFBF;'"
For spalt = 1 To sp_zahl
txt = txt & "kleinergleichth " & style_tmp & "größergleich" & Ü_schr_arr(spalt - 1) & " _
kleinergleich/thgrößergleich"
Next
txt = "kleinergleichtrgrößergleich" & txt & "kleinergleich/trgrößergleich"
'Datenbereich
For zeil = 1 To z_zahl
txt = txt & "kleinergleichtrgrößergleich"
For spalt = 1 To sp_zahl
txt = txt & "kleinergleichtdgrößergleich" & txt_arr(zähl) & "kleinergleich/tdgröß _
ergleich"
zähl = zähl + 1
Next spalt
txt = txt & "kleinergleich/trgrößergleich"
Next zeil
html_tab_text = "kleinergleichtable border=""1""größergleich" & txt & "kleinergleich/ _
tablegrößergleich"
End Function

Ich hoffe, du kommst damit soweit klar....
Gruß, MCO

Beliebteste Forumthreads (12 Monate)

Mail Makro: Tabelle in html text einfügen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mail Makro: Tabelle in html text einfügen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread