[Gelöst]Erstellen und versenden von EMails über die dvapi32 mit Vorlagen und Latebinding in VBA

Public Function EMail_VersendenTobit(EMailAdresse, BetreffTxt As String, EMailText As String, Optional SofortSendenOderAnzeigen As Integer, Optional davidAppl, Optional AttachmentsPathsLöschen As Boolean) As Boolean
On Error GoTo Err_End1


'*** für das Verständnis noch die dvapi32 Typen ***
'Dim obj_App As DvApi32.IApplication
'Dim obj_Account As DvApi32.Account
'Dim obj_Archive As DvApi32.Archive
'Dim obj_MailItem As DvApi32.MessageItem2
'Dim oAttachment As DvApi32.Attachment
Dim I As Integer
Dim obj_App As Object
Dim obj_Account As Object
Dim obj_Archive As Object
Dim obj_MailItem As Object
Dim str_RecNo As String
Dim obj_WshShell As Object
Dim str_ShellCmd As String
Dim str_TobitPath As String
Dim str_TobitSvr As String
Dim str_Template As String
Dim str_Templatefn As String


'*** erstellen der Objekte ***
Set obj_App = CreateObject("DVOBJAPILib.DvISEAPI")
Set obj_Account = obj_App.Logon("", "", "", "", "", "AUTH")
Set obj_Archive = obj_Account.GetSpecialArchive(102) 'Konstante "102" gibt Ausgangsarchiv an!
Set obj_MailItem = obj_Archive.CreateArchiveEntry(2) 'Konstante "2" steht für Email!


'*** Tobit Servername auslesen ***
str_TobitSvr = obj_Account.ServerName


'*** Vorlagenverzeichnis einlesen ***
Set obj_WshShell = CreateObject("WScript.Shell")
str_ShellCmd = "HKCU\Software\Tobit\Tobit InfoCenter\Servers\" & str_TobitSvr & "\TemplateFN"
str_Template = obj_WshShell.RegRead(str_ShellCmd)
str_Templatefn = Right(str_Template, (Len(str_Template) - InStrRev(str_Template, "\")))


'*** Erststellen der Email ***
With obj_MailItem
    .Fields("SRTo").Value = FNz(EMailAdresse, "")
'*** CC und BCC benötigen 2 dimensionale Arrays als Übergabe! ***
'    .Fields("Cc").Value = FNz(EMailAdresse_CC, "")
'    .Fields("BCc").Value = FNz(EMailAdresse_BCC, "")
    .Subject = ""
    .Fields("CONTENT").Value = FNz(EMailText, "")
    .Fields("Subject").Value = FNz(BetreffTxt, "")
    .Fields("Priority").Value = 0
    '.Fields("SourceFileName").Value = str_Template
End With


If SofortSendenOderAnzeigen = 0 Then
    obj_MailItem.Save
    '*** RecNo = ID der erstellten Email! ***
    str_RecNo = obj_MailItem.Fields("RecNo").Value


    '*** öffnen der Email in Tobit ***
    str_ShellCmd = str_TobitPath & "\DVWIN32.EXE " & obj_Archive.ID & " /SA=34 /POS=" & str_RecNo & " /FROM=" & str_Template
    obj_WshShell.Exec (str_ShellCmd)


    '*** Wichtig!!! Löschen des Emailobjekts! Sonst ist Email doppelt vorhanden! ***
    obj_MailItem.Delete
 Else
    '*** normales Senden der Email ***
    obj_MailItem.Send
    Set obj_MailItem = Nothing
End If


Exit_End1:
    Exit Function
Err_End1:
    Select Case ErrorHandler(""): Case Is = 5: Resume Next: Case Is = 4: Resume: End Select: Resume Exit_End1
    Resume
End Function

Public Function EMail_VersendenTobit(EMailAdresse, BetreffTxt As String, EMailText As String, AttachmentsPaths() As String, Optional SofortSendenOderAnzeigen As Integer, Optional davidAppl, Optional AttachmentsPathsLöschen As Boolean) As Boolean
On Error GoTo Err_End1


'*** Zum Verständnis die Tobit Variablen ***
'Dim obj_App As DvApi32.IApplication
'Dim obj_Account As DvApi32.Account
'Dim obj_Archive As DvApi32.Archive
'Dim obj_MailItem As DvApi32.MessageItem2
'Dim obj_TemplateArchiv As DvApi32.Archive
'Dim obj_TemplateMItem As DvApi32.MessageItem2


Dim I As Integer
Dim obj_App As Object
Dim obj_Account As Object
Dim obj_Archive As Object
Dim obj_MailItem As Object
Dim obj_TemplateArchiv As Object
Dim obj_TemplateMItem As Object
Dim str_RecNo As String
Dim obj_WshShell As Object
Dim str_ShellCmd As String
Dim str_TobitPath As String
Dim str_TobitSvr As String
Dim str_TemplateFile As String
Dim arr_Empfaenger(0, 1) As String


'*** erstellen der Objekte ***
Set obj_App = CreateObject("DVOBJAPILib.DvISEAPI")
Set obj_Account = obj_App.Logon("", "", "", "", "", "AUTH")
Set obj_Archive = obj_Account.GetSpecialArchive(102) 'Konstante "102" gibt Ausgangsarchiv an!
Set obj_MailItem = obj_Archive.CreateArchiveEntry(2) 'Konstante "2" steht für Email!


'*** Tobit Servername auslesen ***
str_TobitSvr = obj_Account.ServerName


'*** Vorlagenverzeichnis einlesen ***
Set obj_WshShell = CreateObject("WScript.Shell")
str_ShellCmd = "HKCU\Software\Tobit\Tobit InfoCenter\Servers\" & str_TobitSvr & "\TemplateFN"
str_TemplateFile = obj_WshShell.RegRead(str_ShellCmd)


Set obj_TemplateArchiv = obj_Account.GetSpecialArchive(10) 'Konstante "10" gibt TemplateOrdner an!
Set obj_TemplateMItem = obj_TemplateArchiv.GetArchiveEntryByID(Trim(str_TemplateFile))


'*** Erststellen der Email ***
With obj_MailItem
    arr_Empfaenger(0, 0) = EMailAdresse
    arr_Empfaenger(0, 1) = EMailAdresse
    .Fields("To").Value = arr_Empfaenger


'*** CC und BCC benötigen 2 dimensionale Arrays als Übergabe! ***
'    .Fields("Cc").Value = FNz(EMailAdresse_CC, "")
'    .Fields("BCc").Value = FNz(EMailAdresse_BCC, "")


    .Fields("HTML").Value = TobitFixUmlaute(obj_TemplateMItem.Fields("HTML").Value) 'FNz(EMailText, "")
    .Fields("HTMLDisplayContent").Value = TobitFixUmlaute(obj_TemplateMItem.Fields("HTMLDisplayContent").Value) 'FNz(EMailText, "")
    .Fields("Subject").Value = FNz(BetreffTxt, "")
    .Fields("Priority").Value = 0


    For I = 0 To UBound(AttachmentsPaths, 1)
        If AttachmentsPaths(I) <> "" Then
            If fs.FileExists(AttachmentsPaths(I)) Then
                .Attachments.Add (AttachmentsPaths(I))
            End If
        End If
    Next I
End With


If SofortSendenOderAnzeigen = 0 Then
    obj_MailItem.Save
    '*** RecNo = ID der erstellten Email! ***
    str_RecNo = obj_MailItem.Fields("RecNo").Value 'obj_TemplateMItem.Fields("RecNo").Value
    '*** öffnen der Email in Tobit ***
    str_ShellCmd = str_TobitPath & "\DVWIN32.EXE " & obj_Archive.ID & " /SA=34 /POS=" & str_RecNo
    obj_WshShell.Exec (str_ShellCmd)
    '*** Wichtig!!! Löschen des Emailobjekts! Sonst ist Email doppelt vorhanden! ***
    obj_MailItem.Delete
 Else
    '*** normales Senden der Email ***
    obj_MailItem.Send
    Set obj_MailItem = Nothing
End If


EMail_VersendenTobit = True


Exit_End1:
    Exit Function
Err_End1:
    Select Case ErrorHandler(""): Case Is = 5: Resume Next: Case Is = 4: Resume: End Select: Resume Exit_End1
    Resume
End Function