armin-k
Goto Top

Mit Excel 2010 (VBA) eine Mail erzeugen und als Anlage einen Termin erstellen

Liebes Forum,

aus verschiedenen Inhalten habe Teile von VBA-Codes zusammengesucht und bin folgende Problemstellung angegangen:

Mit Excel / VBA möchte ich aus Teilen meiner Tabelle eine Mail mit individuellem Text und als Anlage einen Termin mit Daten aus dieser Excel-Tabelle erzeugen und verschicken.

"Meine" Lösung funktioniert dubioserweise in der Office 2016 Umgebung, aber in der Office 2010 Umgebung bekomme ich immer dann eine Fehlermeldung („Die Methode“ForwardAsVcal für das Objekt ‚_AppointmentItem‘ ist fehlgeschlagen“), wenn Outlook beim Makroaufruf noch geschlossen ist. Ist Outlook vor dem Makroaufruf geöffnet, wird das Makro wohl richtig abgearbeitet.


Sub Mailing_und_Termin()
    
   
   
    Dim rng As Range
    Dim OutApp As Object
    Dim OutApptmt As Object
    Dim OutMail As Object
    Dim olOldBody As String
    Dim Beschreibung As String
    Dim Beschreibung1 As String
    Dim Beschreibung2 As String
    Dim Beschreibung3 As String
    Dim Beschreibung4 As Date
    Dim Beschreibung5 As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
 
    Set OutApp = CreateObject("Outlook.Application")  
 
    Beschreibung = Sheets("Tabelle1").Range("c1")  'FD  
    Beschreibung1 = Sheets("Tabelle1").Range("c2") 'Vertrags-Nr  
    Beschreibung2 = Sheets("Tabelle1").Range("c3") 'Vertragspartner  
    Beschreibung3 = Sheets("Tabelle1").Range("c4") 'Vertragsgegenstand  
    Beschreibung4 = Sheets("Tabelle1").Range("c5") 'T für Wvl  
    Beschreibung5 = Sheets("Tabelle1").Range("c6") 'Grund für Wvl  
    
    Set OutApptmt = OutApp.CreateItem(1)
    With OutApptmt
     
    
        .Subject = "Veränderung in den Wvl. der Vertragsdaten"  
        .Start = Beschreibung4
        '.Start = Now + 1  
        '.End = DateAdd("h", 1, .Start)  
        .AllDayEvent = True
        .Body = Beschreibung & Chr(13) & Chr(13) _
            & "Vertrag-Nr.:" & String(30, " ") & Beschreibung1 & Chr(13) _  
            & "Vertragspartner:" & String(21, " ") & Beschreibung2 & Chr(13) _  
            & "Vertragsgegenstand:" & String(12, " ") & Beschreibung3 & Chr(13) _  
            & "Termin für Wvl.:" & String(22, " ") & Beschreibung4 & Chr(13) _  
            & "Grund für Wvl.:" & String(23, " ") & Beschreibung5 & Chr(13) & Chr(13) _  
            & String(12, " ") & "eingetragen am:    " & Date  
            
            
        .MeetingStatus = 1  '1=olMeeting  
        '.RequiredAttendees = "max.mustermann@muster.com"  
        .Save
        Set OutMail = .ForwardAsVcal
    End With
 
    'On Error Resume Next  
    With OutMail
        .GetInspector.display
        olOldBody = .HTMLBody
        .To = "max.muster@icloud.com"  
        .cc = ""  
        .bcc = ""  
        .Subject = "Terminveränderung im Vertragsregister des FD 30"  
        .HTMLBody = RangeToHTML(Sheets("Tabelle1").Range("A8:d20"))  
        .display
        .Send
    End With
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangeToHTML(rng As Range)
    Dim Fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"  
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    Set ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.readall
    ts.Close
    RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", _  
                          "align=left x:publishsource=")  
    TempWB.Close SaveChanges:=False
    Kill TempFile
    Set ts = Nothing
    Set Fso = Nothing
    Set TempWB = Nothing
End Function

Vielleicht hat einer von Euch eine gute Idee und kann mir helfen. Vorab auf jeden Fall schon mal vielen Dank ... + LG

Frage ist derzeit noch aktiv, vielleicht habe ich es in der falschen "Themengruppe" veröffentlicht, hat jemand noch eine Idee....

Content-Key: 301455

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

Ausgedruckt am: 28.03.2024 um 16:03 Uhr