Beiträge von fdieck

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


Dim TobitPath
Dim TSrv
Dim Template


'TEST ARRAY
'Dim arr_Empfaenger(0, 1) 


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()
  dim vHtml
  dim vAttachment, vSubject, vTo, vBCC
  dim vStackSize




  '**************************
  ' Daten holen


  vTo = Aeins.JVARS_GET(3551, "JVAR_TEMPWERT_3")
  vSubject = Aeins.JVARS_GET(3551, "JVAR_TEMPWERT_2")
  vAttachment = Aeins.JVARS_GET(3551, "JVAR_TEMPWERT_4")
  vBCC = Aeins.JVARS_GET(3551, "JVAR_VERSANDOUTLOOK_BCC")
  vHtml = Aeins.JVARS_GET(3551, "JVAR_TEMPWERT_1")
  vHtml = Replace(vHtml, Chr(10) & Chr(10), "<br>")
  vHtml = Replace(vHtml, Chr(13), "<br>")


  '**************************




  '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 = vSubject


  	'Empfänger der Nachricht 
  	.Fields("SRTo").Value = vTo


                                          ' TEST
                                          ' arr_Empfaenger(0, 0) = Aeins.JVARS_GET(3551, "JVAR_TEMPWERT_3")
                                          'arr_Empfaenger(0, 1) = Aeins.JVARS_GET(3551, "JVAR_TEMPWERT_3")
                                           '.Fields("To").Value =  arr_Empfaenger
  	'Priorität der Nachricht
  	.Fields("Priority").Value = 0 '0 = Normal, 1 = Low, 2 = Important
  	'Daten der Vorlage einlesen


         .Fields("HTMLDisplayContent").Value = vHtml
    'vorher StackSize = 1000
    vStackSize = 5 
    Do While vStackSize > 0
      vAttachment = ""
      vAttachment = Aeins.JVARS_GET(3551, "JVAR_VERSANDOUTLOOK_DATEI_" & vStackSize)


      if len(vAttachment) > 0 then
        oMailItem.Attachments.Add ""+vAttachment+"", vAttachment
        call Aeins.JVARS_SET(3551, "JVAR_VERSANDOUTLOOK_DATEI_" & vStackSize, "")
      end if  


      vStackSize = vStackSize - 1
     Loop




                 '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
                                                                                      ' zum TESTEN mal ausgeklammert BEWIRKT DAS DIE MAIL NICHT IM EDITOR GEÖFFNET WIRD!
	'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


                MsgBox vTo
                oMailItem.To = vTo
                'TEST ob das direkte Senden geht LEGT ANSCHEINEND ADRESSE NICHT AN                
                oMailItem.Send


	'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,"ä","ä")
  RetValue = Replace(RetValue,"Ä","Ä")
  RetValue = Replace(RetValue,"ö","ö")
  RetValue = Replace(RetValue,"Ö","Ö")
  RetValue = Replace(RetValue,"ü","ü")
  RetValue = Replace(RetValue,"Ü","Ü")


  FixHTMLUmlaute = RetValue
End Function