Office: Tobit David neue Email HTML mit Vorlage und Anhang

stuz1 · 28. Mai 2012

Hallo zusammen,

ich habe mich jetzt Tagelang mit der DVApi von Tobit auseinander gesetzt da ich meine Anwendung mehr oder weniger nahtlos daran anbinden möchte. Da es im Netz nicht viel brauchbares gibt um von außen Mails mit Tobit zu erstellen habe ich meine jetzige Lösung hier abgelegt in der Hoffnung dass es manch anderem vielleicht Arbeit erspart:

Die Mail wird vor dem versenden zunächst noch angezeigt.... den HTML-Body selbst zu füllen und ggf. weitere Dinge damit zu tun dürfte somit nicht schwer fallen... (man muss ja nicht alles vorkauen... grins)

Das Ding ist auch schon "fast" latebinding-fähig... ein paar Konstanten müssten noch schnell ausgetauscht werden....

Gruß

Stefan

Code:

Option Compare Database
Option Explicit

'*********************************************************************************
'* Modul zum erstellen einer Tobit-David Mail mit HTML UND Benutzervorlage *
'* Original von psymaniac auf www.schneller-und-besser.de gefunden *
'* Modifiziert von Stefan Zink 30.05.2012 *
'*********************************************************************************

'Modulweite Variablen
Dim oApp As DvApi32.DavidAPI
Dim oAccount As DvApi32.Account
Dim oItem As DvApi32.MailItem
Dim oArchive As DvApi32.Archive
Dim Template As String
Dim TobitPath As String

'Diese Sub in Code einbauen, Anhang als kompletten Pfad angeben (z.B. "c:\Test.txt")
Sub EmailAnlegen(Empfaenger As String, Optional Anhang As String = vbNullString)

InitTobit
Create_NewMail Empfaenger, Anhang

End Sub

Sub InitTobit()
Dim WSHShell As Object
Dim ShellCmd As String
Dim Path As String
Dim filepart As String
Dim i As Long

Dim TSrv As String
Dim oArchiveRoot As DvApi32.Archive
Dim oArchives As DvApi32.Archives

Dim oMessageItems As DvApi32.MessageItems
Dim obj As DvApi32.MailItem
'Initialisiert die Tobit API

'Anwendungsverzeichnis des Tobit InfoCenters aus der Registry auslesen
Set WSHShell = CreateObject("WScript.Shell")
ShellCmd = "HKCU\Software\Tobit\Tobit InfoCenter\Settings\ProgramDirectory"
TobitPath = WSHShell.RegRead(ShellCmd)

'Objekt der DvISEAPI erzeugen
Set oApp = CreateObject("DVOBJAPILib.DvISEAPI")

'Account laden (des lokal angemeldeten Benutzers)
Set oAccount = oApp.Logon("", "", "", "", "", "NOAUTH")

'Alle Archive einlesen
Set oArchiveRoot = oAccount.ArchiveRoot
Set oArchives = oArchiveRoot.Archives

'Tobit Servernamen auslesen (Hostname des Tobit Servers in der Regel)
TSrv = oAccount.ServerName

'Vorlagenverzeichnis einlesen
ShellCmd = "HKCU\Software\Tobit\Tobit InfoCenter\Servers\" & TSrv & "\TemplateFN"
Template = WSHShell.RegRead(ShellCmd)

'Falls möglich Vorlage einlesen
If Template "" Then
'Den Pfad abschneiden
Path = Template
filepart = Right(Template, 13)
Path = Replace(Template, filepart, "")

Set oArchive = oAccount.ArchiveFromID(Path)
Set oMessageItems = oArchive.AllItems

'Das Archiv ermitteln
For i = 0 To oMessageItems.Count - 1
If oMessageItems.Item(i).Type = DvEMailItem Then
Set obj = oMessageItems.Item(i)
If obj.TextSource = Template Then
Set oItem = obj
Exit For
End If
End If
Next i
End If

Set oArchiveRoot = Nothing
Set oArchives = Nothing
Set oMessageItems = Nothing
Set obj = Nothing

End Sub

'*********************************************************************************
'* SUB Create_NewMail() *
'*********************************************************************************
Sub Create_NewMail(Empfaenger As String, Anhang As String)
Dim HTML As String
Dim Text As String
Dim Charset As String
Dim oRecNo As String
Dim WSHShell As Object
Dim ShellCmd As String
Dim oMailItem As DvApi32.MessageItem2

'Tobit Archiv einlesen
Set oArchive = oAccount.GetSpecialArchive(102) '102 = Ausgangsarchiv

'Neuen Archiveintrag anlegen
Set oMailItem = oArchive.CreateArchiveEntry(2) '0 = unbekannt, 1 = Adresse, 2 = Email, 3 = Fax, 4 = SMS, 5 = VoiceMail, 6 = TMAIL, 7 = Kalendereintrag, (...)

With oMailItem

.Subject = ""

'Empfänger der Nachricht
.Fields("SRTo").Value = Empfaenger
'Betreff
'.Fields("Subject").Value = "TestBetreff"
'Priorität der Nachricht
.Fields("Priority").Value = 0 '0 = Normal, 1 = Low, 2 = Important

'Daten der Vorlage einlesen
If Template "" Then

HTML = oItem.BodyText.HTMLText

'Fix für Umlaute da diese trotz UTF-8 komischerweise nicht sauber dargestellt werden
HTML = FixHTMLUmlaute(HTML)
Text = oItem.BodyText.PlainText
Charset = oItem.BodyText.Charset

.Fields("CONTENT").Value = Text
.Fields("HTMLDisplayContent").Value = HTML
End If

'ggf. Dateianhänge hinzufügen
If Not Anhang = vbNullString Then
.Attachments.Add Anhang ', "Angezeigte Bezeichnung des Anhangs"
End If

'Nachricht speichern
.Save

End With

'Nummer des Eintrags der soeben gespeicherten Email auslesen (wichtig für Shell Aufruf!)
oRecNo = oMailItem.Fields("RecNo").Value

'Über die Shell das InfoCenter starten und dort die soeben erzeugte Nachricht im Editor öffnen
Set WSHShell = CreateObject("WScript.Shell")
ShellCmd = TobitPath & "\DVWIN32.EXE " & oArchive.Id & " /SA=34 /POS=" & oRecNo
WSHShell.Exec (ShellCmd)

'Mail sofort wieder löschen nachdem sie geöffnet wurde, da Sie sonst doppelt versendet wird, bzw. 2x im Postausgangsarchiv liegt
oMailItem.Delete

'Objekte freigeben um sicherzustellen, dass das Script auch bei mehrmaligem Aufrufen sauber funktioniert
oAccount.Logoff
Set WSHShell = Nothing
Set oAccount = Nothing
Set oApp = Nothing
Set oMailItem = Nothing
Set oArchive = Nothing
Set oItem = Nothing
End Sub

'*********************************************************************************
'* FUNCTION FixHTMLUmlaute( HTML_Content ) *
'*********************************************************************************
Function FixHTMLUmlaute(HTML_Content)
'Der Funktion wird ein HTML Fragment übergeben.
'In diesem werden dann die Umlaute gegen die entsprechenden Codes ersetzt.
Dim RetValue As String

RetValue = Replace(HTML_Content, "ä", "ä")
RetValue = Replace(RetValue, "Ä", "Ä")
RetValue = Replace(RetValue, "ö", "ö")
RetValue = Replace(RetValue, "Ö", "Ö")
RetValue = Replace(RetValue, "ü", "ü")
RetValue = Replace(RetValue, "Ü", "Ü")
RetValue = Replace(RetValue, "ß", "ss")

FixHTMLUmlaute = RetValue
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

Thomas Möller · 30. Mai 2012

Hallo Stefan,

die Funktion FixHTMLUmlaute richtet zwar keinen Schaden an, aber bist Du sicher, dass sie tut, was der Kommentar verspricht?

CU

Arne Dieckmann · 30. Mai 2012

zu der Funktion FixHTMLUmlaute: Da funkt nun leider die Einstellung "HTML ist erlaubt" des Forums dazwischen.

Wenn man die "&" durch "&amp ;" (ohne Leerzeichen) ersetzt, passt die Darstellung.

stuz1 · 30. Mai 2012

Hallo Thomas,
Hmmmm.... Stimmt. Aber im Original sieht das tatsächlich anders aus. Versuche das morgen noch anders zu Posten.

Danke für den Hinweis

Stefan

stuz1 · 30. Mai 2012

Habe hier jetzt nochmal die Funtkion FixHTMLUmlaute

Jetzt müssen aber die Unterstriche nach den "&" entfernt werden.....

Ich hoffe das ist so verständlich....

Have a nice day together....

Code:

Function FixHTMLUmlaute(HTML_Content)
'Der Funktion wird ein HTML Fragment übergeben.
'In diesem werden dann die Umlaute gegen die entsprechenden Codes ersetzt.
Dim RetValue As String

RetValue = Replace(HTML_Content, "ä", "&_auml;")
RetValue = Replace(RetValue, "Ä", "&_Auml;")
RetValue = Replace(RetValue, "ö", "&_ouml;")
RetValue = Replace(RetValue, "Ö", "&_Ouml;")
RetValue = Replace(RetValue, "ü", "&_uuml;")
RetValue = Replace(RetValue, "Ü", "&_Uuml;")
RetValue = Replace(RetValue, "ß", "ss")

FixHTMLUmlaute = RetValue
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: Tobit David neue Email HTML mit Vorlage und Anhang

Tobit David neue Email HTML mit Vorlage und Anhang

Tobit David neue Email HTML mit Vorlage und Anhang

Tobit David neue Email HTML mit Vorlage und Anhang

Tobit David neue Email HTML mit Vorlage und Anhang - Similar Threads - Tobit David Email

Fehler (0x800CCC78) beim Ausführen der Aufgabe "xx.yyyy@kabelmail.de - Nachrichten werden gesendet"

Serien-Email mit Anhang realisieren

alle bisherigen Emails nicht mehr vorhanden

eingehende Emails über bestimmtes Konto automatisch weiterleiten

Schriftgröße in Email Unterordner ändern...

Kann keine Email mehr verschicken

Outlook-Email-Konten