AW: Text aus Textbox in E-Mail Body
02.06.2017 17:22:39
Oisse
Danke für deine Antwort.
Ich stelle gerne den (sehr umfangreichen) Code rein. Hoffentlich ist er für euch übersichtlich genug.
Kurz erklärt passiert folgendes:
Aus dem Sheet "Newsletter" wird ein Worddokument gefüllt, das man noch abändern kann, bevor es als pdf gespeichert wird.
Dieses Pdf wird dann als Anhang an Emailempfänger gesandt. Diese Email soll eben den Text haben, der in der TextBox (war ja die erste Variante) oder in der Zelle "A1" steht (zweite Variante).
Hier also der Code:
Public Sub Newsletter()
'On Error GoTo Fehler
Dim WordObj As Object
Dim strPfad As String
Dim Datum As Date
Dim strAdress As String
Dim Text As String
Dim Aufseher As String
Dim eMailMA As String
Dim Ang As String
Dim CDateiName As String
Dim wks_Ang As Worksheet
Dim wks_Ein As Worksheet
Dim wks_Email As Worksheet
Dim Emailtext As String
Set wks_Ang = ThisWorkbook.Worksheets("Newsletter")
Set wks_Ein = Workbooks("Artikelliste.xlsm").Worksheets("Käuferadressen")
Emailtext = wks_Ang.Shapes("E-Mailtext").TextFrame.Characters.Text
'Set wks_Email = ThisWorkbook.Worksheets("Emailtext")
'Emailtext = wks_Email.Range("A1").Characters.Text
Datum = Date
Aufseher = wks_Ein.Cells(2, 12)
eMailMA = wks_Ang.Cells(13, 6)
'Die zwei Zellen, aus denen sich die Angebotsnummer zusammensetzt (Jahreszahl und fortlaufende _
Nummer)
Ang = wks_Ang.Cells(16, 9)
'Die Speicheradresse und der Speichername mit Käufer, Angebotsnummer und Datum
CDateiName = ThisWorkbook.Path & "\NewsletterExtern\" & " Newsletter Nr. " & Ang & " " & _
Datum & ".PDF"
On Error Resume Next
Set WordObj = GetObject(, "Word.Application")
If WordObj Is Nothing Then
Set WordObj = CreateObject("Word.Application")
Else
End If
WordObj.Documents.Add (ThisWorkbook.Path & "\Vorlagen\NewsletterExtern.docx")
WordObj.Visible = True
'Ab hier werden die einzelnen Zellen kopiert, und in die vorhandenen bookmards (Textmarken in _
Word) mit den entspr. Namen eingefügt:
'Zellenbereich dynamisch ab Zeile 20 von Spalte A bis G kopieren, dies ist der Bereich in _
dem die Artikel stehen mit Position und Stückzahl
lz = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
ActiveSheet.Range("A19:F" & lz).Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Angebot") Then
WordObj.Selection.GoTo What:=-1, Name:="Angebot" '-1 = wdGoToBookmark
WordObj.Selection.Paste
Application.CutCopyMode = False
WordObj.Selection.Tables(1).Rows(1).HeadingFormat = True
WordObj.Selection.Tables(1).Rows.LeftIndent = Application.CentimetersToPoints(-1)
End If
wks_Ang.Range("I16").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("AngNr") Then
WordObj.ActiveDocument.Bookmarks("AngNr").Range = Ang
Else
MsgBox "Die Textmarke MarkeAngNr ist nicht vorhanden"
End If
ThisWorkbook.Sheets(wks_Ang).Range("I11").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Zeichen") Then
WordObj.ActiveDocument.Bookmarks("Zeichen").Range = wks_Ang.Range("I11").Value
Else
MsgBox "Die Textmarke MarkeZeichen ist nicht vorhanden"
End If
ThisWorkbook.Sheets(wks_Ang).Range("I12").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Durchwahl") Then
WordObj.ActiveDocument.Bookmarks("Durchwahl").Range = wks_Ang.Range("I12").Value
Else
MsgBox "Die Textmarke MarkeDurchwahl ist nicht vorhanden"
End If
ThisWorkbook.Sheets(wks_Ang).Range("I13").Copy
If WordObj.ActiveDocument.Bookmarks.Exists("Datum") Then
WordObj.ActiveDocument.Bookmarks("Datum").Range = wks_Ang.Range("I13").Value
Else
MsgBox "Die Textmarke MarkeDatum ist nicht vorhanden"
End If
If WordObj.ActiveDocument.Bookmarks.Exists("Angebot") Then
WordObj.ActiveDocument.Bookmarks("Angebot").Activate.Rows.HeadingFormat = wdToggle
Else
MsgBox "Die Textmarke MarkeAngebot ist nicht vorhanden"
End If
' With WordObj
' .ActiveDocument.SaveAs Filename:=CDateiName 'Als Word Dokument speichern
'End With
If MsgBox("Ändere ggf. das Word-Dokument ab und klicke danach hier OK", vbOKCancel, "Durchsicht _
des Dokuments") = vbOK Then
'Als Pdf speichern
With WordObj
With .ActiveDocument
.ExportAsFixedFormat OutputFileName:=CDateiName, _
ExportFormat:=17, Openafterexport:=True, OptimizeFor:=0, _
Range:=0, From:=1, To:=1, _
Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=0, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
.Close SaveChanges:=False
End With
End With
Else
WordObj.ActiveDocument.Close SaveChanges:=False
Exit Sub
End If
Rem Empfängerliste zusammenstellen
For i = 11 To wks_Ang.Range("L" & Rows.Count).End(xlUp).Row
If strAddress = "" Then
strAddress = wks_Ang.Cells(i, 12)
Else
strAddress = strAddress & ";" & wks_Ang.Cells(i, 12)
End If
Next i
Rem Email erstellen
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .htmlBody
'.To = strAddress
.CC = Aufseher & "; " & eMailMA
.BCC = strAddress
.Subject = "Newsletter" ' Betreff
.htmlBody = Emailtext
' .htmlBody = "Sehr geehrte _
Damen und Herren,
" & _
' "anbei finden Sie eine Übersicht ausgewählter Artikel, welche zum _
Verkauf stehen.
" & _
' "Sie interessieren sich für unsere Artikel? Kontaktieren sie uns _
telefonisch oder per Antwort auf diese E-Mail zur Terminabsprache, um zu einem beiderseits verbindlichen Angebot zu kommen.
" & _
' "Sie können sich auch gerne selbst unter folgender Adresse nach _
vorheriger Vereinbarung diese und weitere Produkte ansehen.
" & _
' "Bitte beachten Sie, dass die Artikel 'wie gesehen' angeboten werden. _
Daher können später keine Garantie oder mögliche Beanstandungen angezeigt werden.
" '& olOldBody Body. "
" = Zeilenumbruchanweisung"
.Attachments.Add CDateiName 'Datei anhängen
End With
'WordObj.Quit SaveChanges:=wdDoNotSaveChanges
Set WordObj = Nothing
wks_Ang.Visible = True
End Sub
Danke dass du/ihr hilfst/helft.
Gruß Oisse