Thema Datum  Von Nutzer Rating
Antwort
Rot Email aus Outlook mit VBA in Word drucken: Umlautp
 10.11.2009 22:31:11 Sheik
NotSolved

Ansicht des Beitrags:
Von:
Sheik		 Datum:
10.11.2009 22:31:11		 Views:
1736		 Rating:
     
Antwort:
  Ja
Thema:
Email aus Outlook mit VBA in Word drucken: Umlautp
Folgendes Macro läuft gut auf Outlook:
1.Email auswählen
2.Makro starten (Word wird geöffnet und Email wird dort in Platzhalter eingefügt.
Das Problem ist, dass Umlaute falsch dargestellt werden.

Code:
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
If .BodyFormat = olFormatHTML Then
mb = .HTMLBody
End If
If .BodyFormat = olFormatPlain Then
mb = .Body
End If
If .BodyFormat = olFormatRichText Then
mb = .Body
End If

'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#§&"
If Textformat = 1 Then .Replacement.Text = CStr(Textformat) + " ( TXT )"
If Textformat = 2 Then .Replacement.Text = CStr(Textformat) + " ( HTML )"
If Textformat = 3 Then .Replacement.Text = CStr(Textformat) + " ( RTF )"
.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

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Email aus Outlook mit VBA in Word drucken: Umlautp
 10.11.2009 22:31:11 Sheik
NotSolved