Email über VBScript erstellen und im InfoCenter öffnen (Mit Benutzung der Email Vorlage für neue Nachrichten)

Dim oApp 
Dim oAccount 
Dim oArchive 
Dim oItem
Dim oMailItem 
Dim oAttachment  


Dim TobitPath
Dim TSrv
Dim Template


InitTobit()
Create_NewMail()






'*********************************************************************************
'*                       	SUB InitTobit()                                 	*
'*********************************************************************************
Sub InitTobit()
ON ERROR RESUME NEXT


  '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,"")

	'Das Archiv ermitteln
	For each oArc in oArchives
  	IF oArc.ID = Path THEN 
    	'Das MailItem ermitteln 	
    	For each obj in oArc.AllItems
      	IF obj.TextSource = Template THEN
        	SET oItem = obj
      	END IF
    	Next	
  	End IF
	Next	
  END IF
End Sub


'*********************************************************************************
'*                       	SUB Create_NewMail()                            	*
'*********************************************************************************
Sub Create_NewMail()


  '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 = "H.Tobit@tobit.de"


  	'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
	'  .Attachments.Add Path & "\" & FileName ', "Angezeigte Bezeichnung des Anhangs"

  	'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 oAccount = Nothing
	Set oApp = Nothing 
	Set oAttachment = Nothing
	Set oMailItem = Nothing
	Set oArchive = Nothing 
	Set oArchives = Nothing
	Set oItem = Nothing
	Set oArchiveRoot = 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.

  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;")


  FixHTMLUmlaute = RetValue
End Function