Mehrere Mail Vorlagen in VBA Skript verwenden

Hallo zusammen

Ich würde gerne ein Skript anpassen, jedoch komme ich darauf nicht ganz klar..
Das Skript soll folgendes machen können:
Anhand des Standes eine Mailvorlage beziehen und die mailadresse und den Betreff jeweils anpassen, was in der Zeile steht. (siehe Bild unten)

Ich habe hier noch ein Skript, wo mir Colinardo geholfen/gemacht hat, was ziemlich ähnlich eigentlich ist, abgesehen vom Stand..
Ich weiss nicht wie ich den Befehl: "wenn Stand: Absage, beziehe Mailvorlage1", einfügen soll.

Skript:

Sub PrepareOutlookEmail()
    'Pfad zur Outlook-Vorlagendatei im OFT Format  
    Const TEMPLATEPATH = "U:\Firma\Vorlage.oft"  
    'Variablen  
    Dim objOL As Object, fso As Object, intCRow As Long, ws As Worksheet
    'Objekte  
    Set objOL = CreateObject("Outlook.Application")  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    ' selektierte Zeile speichern  
    intCRow = Selection.Row
    ' aktuelles Sheet Variablen zuweisen  
    Set ws = ActiveSheet
    ' in der ausgewählten Zeile sollte mindestens eine AN-Adresse stehen  
    If ws.Cells(intCRow, "M").Value <> "" Then  
        ' Mail auf Basis der Vorlagendatei erstellen  
        With objOL.CreateItemFromTemplate(TEMPLATEPATH)
            'Eigenschaften der Mail mit den Daten im Sheet füllen  
            .To = ws.Cells(intCRow, "M").Value  
            .CC = ws.Cells(intCRow, "F").Value  
            '.BCC = ws.Cells(intCRow, "N").Value  
            .Subject = ws.Cells(intCRow, "O").Value  
            ' Prüfen ob Anhänge eingetragen sind  
            If ws.Cells(intCRow, "Q").Value <> "" Then  
                ' Mehrere Anhänge sollten mit einem "|" voneinander separiert werden,  
                For Each strAttachment In Split(ws.Cells(intCRow, "Q").Value, "|", -1, 1)  
                    ' Anhänge werden vor dem Hinzufügen auf Erreichbarkeit geprüft  
                    If fso.FileExists(Trim(strAttachment)) Then
                        .Attachments.Add Trim(strAttachment)
                    Else
                        MsgBox "ACHTUNG: Der Anhang '" & strAttachment & "' existiert nicht", vbExclamation, "Anhang hinzufügen"  
                    End If
                Next
            End If
            'Mail anzeigen  
            .Display
        End With
    Else
        MsgBox "Es wurde keine gültige Zeile selektiert", vbExclamation  
    End If
    'Cleanup  
    Set objOL = Nothing
    Set fso = Nothing
End Sub

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 331769

Url: https://administrator.de/contentid/331769

Ausgedruckt am: 25.11.2024 um 18:11 Uhr

4 Kommentare

Neuester Kommentar

Hi,
ich glaube, es wird für die Kollegen/innen viel einfacher werden, Dir zu helfen, wenn Du den Code mit Code-Tags versiehst.

E.

So habe es angepasst

hoffe ist nun einfacher

Hi.
Da bietet sich ja ein "Select Case" an:

Sub PrepareOutlookEmail()
    'Variablen  
    Dim objOL As Object, fso As Object, intCRow As Long, ws As Worksheet, TemplatePath as String
    'Objekte  
    Set objOL = CreateObject("Outlook.Application")  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    ' selektierte Zeile speichern  
    intCRow = Selection.Row
    ' aktuelles Sheet Variablen zuweisen  
    Set ws = ActiveSheet
    
    Select Case ws.Cells(intCRow,"P")  
        Case "Absage"  
          TemplatePath = "U:\Firma\Vorlage1.oft"  
        Case "Interview"  
          TemplatePath = "U:\Firma\Vorlage2.oft"  
        Case "Zusage"  
          TemplatePath = "U:\Firma\Vorlage3.oft"  
        Case Else
           TemplatePath = "U:\Firma\AllgemeineVorlage.oft"  
    End Select
    ' in der ausgewählten Zeile sollte mindestens eine AN-Adresse stehen  
    If ws.Cells(intCRow, "M").Value <> "" Then  
        ' Mail auf Basis der Vorlagendatei erstellen  
        With objOL.CreateItemFromTemplate(TemplatePath)
            'Eigenschaften der Mail mit den Daten im Sheet füllen  
            .To = ws.Cells(intCRow, "M").Value  
            .CC = ws.Cells(intCRow, "F").Value  
            '.BCC = ws.Cells(intCRow, "N").Value  
            .Subject = ws.Cells(intCRow, "O").Value  
            ' Prüfen ob Anhänge eingetragen sind  
            If ws.Cells(intCRow, "Q").Value <> "" Then  
                ' Mehrere Anhänge sollten mit einem "|" voneinander separiert werden,  
                For Each strAttachment In Split(ws.Cells(intCRow, "Q").Value, "|", -1, 1)  
                    ' Anhänge werden vor dem Hinzufügen auf Erreichbarkeit geprüft  
                    If fso.FileExists(Trim(strAttachment)) Then
                        .Attachments.Add Trim(strAttachment)
                    Else
                        MsgBox "ACHTUNG: Der Anhang '" & strAttachment & "' existiert nicht", vbExclamation, "Anhang hinzufügen"  
                    End If
                Next
            End If
            'Mail anzeigen  
            .Display
        End With
    Else
        MsgBox "Es wurde keine gültige Zeile selektiert", vbExclamation  
    End If
    'Cleanup  
    Set objOL = Nothing
    Set fso = Nothing
End Sub

Guß schnappi