Mail per VBA mit PDF-Anhang

Hallo,
ich werkle schon geraume Zeit an folgendem Problem rum:
Ich muss für einen Kunden aus einer Excel-Mappe heraus eine Mail versenden können.
Dabei gibt es folgende Bedingungen:
1. Als Attachement gibt es eine PDF-Datei, die vorher erzeugt wurde.
(Name und Speicherpfad sind bekannt)
2. Die Anwender haben als Mail-Client meistens Novell Groupwise oder Lotus Notes,
selten auch MS Outlook (muss also unabhängig von dieser Software funktionieren).
3. Es muss übergeben werden: eine Empfänger-Adresse, ein Subject und das Attachement.
Der Befehl Application.Dialogs(xlDialogSendMail).Show kommt nicht in Frage, da Attachements
nicht definiert werden können.
Ich habe beim Suchen die Windows API-Funktion ShellExecute gefunden.
Aber in keiner Dokumentation stand die Übergabe eines Attachements erläutert.
Ich bin für alle Ideen und Lösungsansätze sehr dankbar.
Grüße
Ralf

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Mail_Senden() Dim objMessage As Object Set objMessage = CreateObject("CDO.Message") objMessage.Subject = "Example CDO Message" objMessage.From = "mail@compucare-ac.de" objMessage.To = "mail@compucare-ac.de" objMessage.TextBody = "This is some sample message text." objMessage.AddAttachment "D:\CC\Kunden\regio iT\Bestellungen aus Warenkorb\Test.pdf" objMessage.Send End Sub

Hallo Ralph,
ich glaube, da fehlt noch einiges, bei mir sieht der Code z. B. so aus.

' **********************************************************************
' Modul: Modul2  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

'Don't Change!
Private Const cstrSchema As String = "http://schemas.microsoft.com/cdo/configuration/"
'End Don't Change!

Private Const cstrSMTPServer As String = "mail.provider.com"  'Fill in your SMTP-Server!
Private Const cstrUSERNAME As String = "Your Username" 'Fill in your Mailaccount Username
Private Const cstrPASSWORD As String = "Your Password" 'Fill in your Mailaccount Password
Private Const cstrADDRESS As String = "name@domain.com" 'Your Mail-Address

Sub sendMail_CDO()
  'original code from http://www.rondebruin.nl/cdo.htm
  Dim rng As Range, rngF As Range
  Dim objMsg As Object, objConf As Object
  Dim vntFields As Variant, strBody As String
  Dim vntAttach As Variant, lngIndex As Long
  
  'Body - always use vbCrLf or vbNewLine to separate lines, don't use vbLf!
  Const strMsg As String = vbCrLf & vbCrLf & "Anbei die Datei zur Einsicht." & vbCrLf & vbCrLf & _
    "Mit freundlichen Grüßen." & vbCrLf & "Ich"
  
  'Attachment(s)
  'One File
  Const cstrAttachment As String = "C:\Testfile.txt"
  
  ''More Files
  'Const cstrAttachment As String = "C:\Testfile.txt;C:\AnotherFile.pdf"
  
  ''None
  'Const cstrAttachment As String = ""
  
  On Error GoTo ErrExit
  
  Set objMsg = CreateObject("CDO.Message")
  Set objConf = CreateObject("CDO.Configuration")
  
  objConf.Load -1    ' CDO Source Defaults
  Set vntFields = objConf.Fields
  With vntFields
    .Item(cstrSchema & "sendusing") = 2
    .Item(cstrSchema & "smtpserver") = cstrSMTPServer
    .Item(cstrSchema & "smtpserverport") = 25
    
    'When you also get the Authentication Required Error you can add this three lines.
    '  .Item(cstrSchema & "smtpauthenticate") = 1
    '  .Item(cstrSchema & "sendusername") = cstrUSERNAME
    '  .Item(cstrSchema & "sendpassword") = cstrPASSWORD
    
    .Update
  End With
  
  With Application
    .EnableEvents = False
    .ScreenUpdating = False
  End With
  
  With Sheets("Tabelle1")
    Set rngF = .Range(.Cells(2, 8), .Cells(.Cells(.Rows.Count, 8).End(xlUp).Row, 8))
  End With
  
  'Mailadressen stehen in Spalte H, Namen mit Anrede in Spalte G
  For Each rng In rngF
    If rng Like "*@*.*" Then
      With objMsg
        strBody = "Sehr geehrte" & IIf(Left(rng.Offset(0, -1).Text, 1) = "F", " " & _
          rng.Offset(0, -1).Text, "r " & rng.Offset(0, -1).Text) & "!" & strMsg
        
        Set .Configuration = objConf
        .To = rng.Text
        .CC = ""
        .BCC = ""
        .From = cstrADDRESS  'Absender
        .Subject = "Testmail" 'Betreff
        .TextBody = strBody
        
        If Len(cstrAttachment) Then
          vntAttach = Split(cstrAttachment, ";")
          For lngIndex = 0 To UBound(vntAttach)
            If Dir(vntAttach(lngIndex), vbNormal) <> "" Then .AddAttachment vntAttach(lngIndex)
          Next
        End If
        
        '      ' Set importance or Priority to high
        '      .Fields("urn:schemas:httpmail:importance") = 2
        '      .Fields("urn:schemas:mailheader:X-Priority") = 1
        '
        '      ' Request read receipt
        '      .Fields("urn:schemas:mailheader:return-receipt-to") = cstrADDRESS
        '      .Fields("urn:schemas:mailheader:disposition-notification-to") = cstrADDRESS
        '
        '      ' Update fields
        '      .Fields.Update
        
        .Send
      End With
    End If
  Next
  
  ErrExit:
  
  If Err.Number <> 0 Then
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description & _
      vbLf & vbLf, vbExclamation, "Fehler"
  End If
  
  With Application
    .EnableEvents = True
    .ScreenUpdating = True
  End With
  
  Set rng = Nothing
  Set rngF = Nothing
  Set objConf = Nothing
  Set objMsg = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mail per VBA mit PDF-Anhang

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread