Weil das Memo-Format in Outlook 2007 ungenügend ist, probiere ich dies hier:
Folgendes Macro läuft gut auf Outlook:
1.Email in Outlook auswählen
2.Makro starten (Word wird geöffnet und Email wird dort in Platzhalter eingefügt.
Das Problem ist, dass bei HTML-Emails Umlaute falsch dargestellt werden. Es wird hierzu Sub HTMLToClipboard (ganz unten) und dann .Selection.Paste in der Application-Word verwendet
Option Explicit
Private Declare Function RegisterClipboardFormat Lib "user32" \_
Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Sub PrintMailInWord()
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim mb As String
Set olApp = Outlook.Application
MaxLänge = 200 'für Replace in Word
dirpath = "c:\Emaildruckvorlagen"
'Aktuell ausgewählte Email verwenden
If TypeName(Application.ActiveExplorer.Selection(1)) = "MailItem" Then
Set objMail = Application.ActiveExplorer.Selection(1)
With objMail
Select Case .BodyFormat
Case olFormatHTML: mb = .HTMLBody
Case olFormatPlain: mb = .Body
Case olFormatRichText: mb = .Body
End Select
'Email auslesen
Absendername = .SenderName
Absender = .SenderEmailAddress
Datum = .CreationTime
Empfänger = .To
ccEmpfänger = .CC
bccEmpfänger = .BCC
Betreff = .Subject
Textformat = .BodyFormat
Nachricht = mb
Textnachricht = .Body
End With
End If
'Word-Druckvorlage im Dialog auswählen und öffnen
Set AppWD = CreateObject("Word.Application") 'Word als Object starten
Set AppWD = CreateObject("Word.Application")
With AppWD
Set fd = .Application.FileDialog(msoFileDialogOpen)
fd.InitialFileName = dirpath + "\*.docx"
fd.Title = "Email-Druck-Vorlage mit Platzhaltern auswählen"
If fd.Show Then
.Application.Documents.Open fd.SelectedItems(1)
fd.Execute
End If
Set fd = Nothing
End With
'Platzhalter durch Daten aus Email ersetzen
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&SenderName#§&"
.Replacement.Text = Absendername
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&SenderEmailAddress#§&"
.Replacement.Text = Absender
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&CreationTime#§&"
.Replacement.Text = Datum
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&To#§&"
.Replacement.Text = Empfänger
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&CC#§&"
.Replacement.Text = ccEmpfänger
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&BCC#§&"
.Replacement.Text = bccEmpfänger
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
Start = 1
Do
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&Subject#§&"
.Replacement.Text = Mid(Betreff, Start, MaxLänge) + "#§&Subject#§&"
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
Start = Start + MaxLänge
Loop Until Start \>= Len(Betreff)
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&Subject#§&"
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&BodyFormat#§&"
Select Case Textformat
Case 1: .Replacement.Text = CStr(Textformat) & " ( TXT )"
Case 2: .Replacement.Text = CStr(Textformat) & " ( HTML )"
Case 3: .Replacement.Text = CStr(Textformat) & " ( RTF )"
End Select
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
If Textformat = 1 Or Textformat = 3 Then
Start = 1
Do
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&Message#§&"
.Replacement.Text = Mid(Textnachricht, Start, MaxLänge) + "#§&Message#§&"
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
Start = Start + MaxLänge
Loop Until Start \>= Len(Textnachricht)
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&Message#§&"
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2
End With
End If
If Textformat = 2 Then
'HTML-Objekt in Word einfügen
Call HTMLToClipboard(mb)
With AppWD.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#§&Message#§&"
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
AppWD.Selection.Paste
End If
'AppWD.documents.Close SaveChanges:=0
'AppWD.Quit
End Sub
'http://www.aboutvb.de/vba/artikel/vbawdhtmltodoc.htm
'Bei Objekt-Fehler Bibliothek MSFORMS Verweis durch
'Erstellen einer beliebigen Userfom einbinden
Public Sub HTMLToClipboard(HTMLText As String)
Dim nCFHTML As Long
Dim nClipboardText As String
'htmlumlaute (HTMLText)
nCFHTML = RegisterClipboardFormat("HTML Format")
nClipboardText = "Version:0.9" & vbCrLf
nClipboardText = nClipboardText & "StartHTML:-1" & vbCrLf
nClipboardText = nClipboardText & "EndHTML:-1" & vbCrLf
nClipboardText = nClipboardText & "StartFragment:000081" & vbCrLf
nClipboardText = nClipboardText & "EndFragment:°°°°°°" & vbCrLf
nClipboardText = nClipboardText & HTMLText & vbCrLf
nClipboardText = Replace(nClipboardText, "°°°°°°" \_
, Format$(Len(nClipboardText), "000000"))
MsgBox nClipboardText
With New DataObject
.Clear
.SetText StrConv(nClipboardText, vbFromUnicode), nCFHTML
'.SetText nClipboardText, nCFHTML
.PutInClipboard
End With
End Sub
'Druckvorlagen-Word-Datei zB
'Absendername = #§&SenderName#§&
'Absender = #§&SenderEmailAddress#§&
'Datum = #§&CreationTime#§&
'Empfänger = #§&To#§&
'ccEmpfänger = #§&CC#§&
'bccEmpfänger = #§&BCC#§&
'Betreff = #§&Subject#§&
'Textformat = #§&BodyFormat#§&
'#§&Message#§&
'muss in c:\Emaildruckvorlagen vorhanden sein