VBA generierter Mailversand über Outlookclient direkt, oder über Exchange?

Option Compare Database
Option Explicit

Private Const olMailItem = 0

Sub pEMailVersand(pEinAA As String, Optional pEinCC As String = "", Optional pEinBCC As String = "", Optional pEinBetreff As String = "kein Betreff", _  
            Optional pEinBody As String = "kein Text", Optional pEinFiles As Variant, Optional pEinFileNamen As Variant, _  
            Optional pEinDirektVers As Boolean = False, Optional pEinSignatur As String = vbNullString)
  On Error GoTo pFehler
  Dim pOutlook As Object
  
  Set pOutlook = CreateObject("Outlook.Application")  
  
  If Not pOutlook Is Nothing Then
    Set pOutlook = Nothing
    If IsMissing(pEinFiles) Then
      pVersand_Outlook pEinAA, pEinCC, pEinBCC, pEinBetreff, pEinBody, , , pEinDirektVers, pEinSignatur
    Else
      pVersand_Outlook pEinAA, pEinCC, pEinBCC, pEinBetreff, pEinBody, pEinFiles, pEinFileNamen, pEinDirektVers, pEinSignatur
    End If
  Else
    Set pOutlook = Nothing
    MsgBox "Derzeit ist auf Ihrem System kein E-Mail-Versand möglich"  
  End If
  
pEnde:
  Exit Sub
  
pFehler:
  MsgBox Err.Description, 16, "Fehlerroutine"  
  Resume pEnde
End Sub

Sub pVersand_Outlook(pEinAA As String, pEinCC As String, pEinBCC As String, pEinBetreff As String, pEinBody As String, _
                Optional pEinFiles As Variant, Optional pEinFileNamen As Variant, Optional pEinDirektVers As Boolean = False, _
                Optional pEinSignatur As String = vbNullString)
  On Error GoTo pFehler
  Dim pOutlook As Object
  Dim pMail As Object
  Dim i As Integer, strFiles As String, tmpFile As String, tmpVerz As String, tmpDatei As String, strSignaturBody As String, strSignaturFile As String
  Dim Pos1 As Long, Pos2 As Long, BodyHTML As String
  
  strFiles = ""  
  Set pOutlook = CreateObject("Outlook.Application")  
  Set pMail = pOutlook.createitem(olMailItem)
  
  With pMail
    If pEinBetreff <> "" Then .subject = pEinBetreff  
    If pEinAA <> "" Then .To = pEinAA  
    If pEinCC <> "" Then .cc = pEinCC  
    If pEinBCC <> "" Then .bcc = pEinBCC  
    'Anlagen hinzufügen  
    If Not IsMissing(pEinFiles) Then
      For i = 1 To UBound(pEinFiles)
        If Not pEinFiles(i) = vbNullString Then
          On Error Resume Next
          .Attachments.Add pEinFiles(i)
          If Err.Number <> 0 Then
            Err.Clear
            tmpVerz = left(pEinFiles(i), InStrRev(pEinFiles(i), "\"))  
            tmpDatei = Right(pEinFiles(i), Len(pEinFiles(i)) - InStrRev(pEinFiles(i), "\"))  
            tmpFile = Dateiauswahl(tmpVerz, tmpDatei)
            If tmpFile = "" Then  
              MsgBox "Sie haben diese Datei '" & tmpDatei & "' nicht ausgewählt."  
            Else
              .Attachments.Add tmpFile
            End If
          End If
          On Error GoTo pFehler
        End If
      Next i
      For i = 1 To UBound(pEinFileNamen)
        If Not pEinFileNamen(i) = vbNullString Then
          strFiles = strFiles & " * " & pEinFileNamen(i) & vbNewLine  
        End If
      Next i
    Else
      strFiles = vbNullString
    End If
    .BodyFormat = olFormatHTML
    .display
    Pos1 = InStr(1, LCase(.HTMLBody), "<body")  
    Pos2 = InStr(Pos1, LCase(.HTMLBody), ">")  
'    VBA.SendKeys "^{HOME}", True  
    If strFiles <> "" Then  
      BodyHTML = mID(.HTMLBody, 1, Pos2 + 0) & "<font face=Futura Lt BT><span style=""font-size:12pt"">" & pEinBody & vbNewLine & vbNewLine & strFiles & "</span></font>" & mID(.HTMLBody, Pos2 + 1)  
'      BodyHTML = Mid(.HTMLBody, 1, Pos2 + 0) & "<font face=arial><span style=""font-size:11pt"">" & Replace(pEinBody, Chr(13), "<br />") & vbNewLine & vbNewLine & strFiles & "<br /></span></font>" & Mid(.HTMLBody, Pos2 + 1)  
'      .HTMLBody = Replace(pEinBody, Chr(13), "<br />") & vbNewLine & vbNewLine & strFiles & vbNewLine & .HTMLBody '& vbNewLine & vbNewLine & strSignaturBody  
      .HTMLBody = BodyHTML
    Else
      BodyHTML = mID(.HTMLBody, 1, Pos2 + 0) & "<font face=Futura Lt BT><span style=""font-size:12pt"">" & pEinBody & "</span></font>" & mID(.HTMLBody, Pos2 + 1)  
'      BodyHTML = Mid(.HTMLBody, 1, Pos2 + 0) & "<font face=arial><span style=""font-size:11pt"">" & Replace(pEinBody, Chr(13), "<br />") & "<br /></span></font>" & Mid(.HTMLBody, Pos2 + 1)  
'      .HTMLBody = Replace(pEinBody, Chr(13), "<br />") & vbNewLine & vbNewLine & .HTMLBody '& strSignaturBody  
      .HTMLBody = BodyHTML
    End If
'    .display  
'    If pEinAA <> "" Then  
'      If pEinSignatur <> "keine Signatur vorhanden" Then  
'        On Error Resume Next  
'        VBA.SendKeys "^{END}", True   'Setzt den Cursor ans Ende der E-Mail  
''          .getinspector.CommandBars.Item("Insert").Controls("Signatur").Controls(pEinSignatur).Execute  
''        BodyHTML = "<table border=0 width=""100%"" style=""Color: #0000FF""" & _  
''               " bgColor=#F0F0F0><tr><td align= ""center"">" & .Body & "</td>" & _  
''               "</tr></table><br>"  
'        .HTMLBody = .Body & strSignaturBody  
'      End If  
'    End If  
    If pEinDirektVers Then
      .send
    End If
  End With
  
pEnde:
  Set pMail = Nothing
  Set pOutlook = Nothing
  Exit Sub
  
pFehler:
  MsgBox Err.Description, 16, "Fehlerroutine"  
  Resume pEnde
End Sub