VBA mail senden mit Outlook Vorlage

[elamigo]

hey hey,

kurz und bündig. Mein Code für das schicken der mails.

Code:

Private Sub CommandButton2_Click()

   Dim FileExtStr As String
   Dim FileFormatNum As Long
   Dim Sourcewb As Workbook
   Dim Destwb As Workbook
   Dim TempFilePath As String
   Dim TempFileName As String
   Dim OutApp As Object
   Dim OutMail As Object
   Dim lngSheet As Long
   Dim lngTMP As Long
   Dim varArrSheets() As Variant
   On Error GoTo Fin
   If ListBox1.ListCount = 0 Then
       MsgBox "Es wurden keine Tabellenblätter gewählt.", vbOKOnly + vbExclamation, "Warnung"
       Exit Sub
   Else
       For lngTMP = 0 To ListBox1.ListCount - 1
           If ListBox1.Selected(lngTMP) Then
               ReDim Preserve varArrSheets(lngSheet)
               varArrSheets(lngSheet) = ListBox1.List(lngTMP)
               lngSheet = lngSheet + 1
           End If
       Next lngTMP
   End If
   
   With Application
       .ScreenUpdating = False
       .EnableEvents = False
       .DisplayAlerts = False
   End With

   Set Sourcewb = ActiveWorkbook

   'Copy the ActiveSheet to a new workbook
   
   'ActiveSheet.Copy
   
   ThisWorkbook.Worksheets(varArrSheets).Copy
   
   Set Destwb = ActiveWorkbook
               
   

   'Determine the Excel version and file extension/format
   With Destwb
   
          If Val(Application.Version) < 12 Then
           'You use Excel 97-2003
           FileExtStr = ".xls": FileFormatNum = -4143
       Else
           'You use Excel 2007-2016
           Select Case Sourcewb.FileFormat
           Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
           Case 52:
               If .HasVBProject Then
                   FileExtStr = ".xlsm": FileFormatNum = 52
               Else
                   FileExtStr = ".xlsx": FileFormatNum = 51
               End If
           Case 56: FileExtStr = ".xls": FileFormatNum = 56
           Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
           End Select
       End If
   End With



   'Save the new workbook/Mail it/Delete it
   ' Pfad anpassen - abschliessenden Backslash nicht vergessen!!!
   
 
   TempFilePath = Environ$("temp") & "\"
   TempFileName = TextBoxDatei.Text
   
   
   Set OutApp = CreateObject("Outlook.Application")
   Set OutMail = OutApp.CreateItem(0)
   
 
   
   With Destwb
       .SaveAs "S:\" & TempFileName & FileExtStr, FileFormat:=FileFormatNum
       On Error Resume Next
       With OutMail
           .To = ""
           .CC = ""
           .BCC = ""
           .Subject = ""
           .Body = ""
           .Attachments.Add Destwb.FullName
           
           'Anhang hinzufügen
           '.Attachments.Add ("U:\Test für Senden.xlsx")
           '.Send or use
           .Display
       End With
       On Error GoTo 0
       .Close savechanges:=False
   End With

   
   'Delete the file you have send
   
   'Kill TempFilePath & TempFileName & FileExtStr
Fin:
   Set OutMail = Nothing
   Set OutApp = Nothing

   With Application
       .ScreenUpdating = True
       .EnableEvents = True
       .DisplayAlerts = True
   End With

   
   
   Unload UserForm1
   
End Sub

hier der "Code" zu mindest denke ich das, für das öffnen der Vorlage. Ich bekomme es irgendwie nicht den Code vernünftig zu implementieren.

Code:

  With OutlookApp.createitemfromtemplate("S:\XXXXXX\XXXX\XXXX\XXXX\Vorlagen\Vorlage.oft")
   Set OutMail = OutApp.CreateItem(0)

PS: oder kann ich es einstellen das der sich den Body der Mail aus einem Word Dokument zieht?

[schauan]

Hallöchen,

oben schreibst DU
Dim OutApp As Object
und dann
With OutlookApp
Da solltest Du Dich für eins entscheiden

Wie wärs mit

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate…
With OutMail
...