Makro Abspeicherung mit Email Erinnerung Funktion

[holiday676]

Hallo zusammen,

Ich habe ein Problem mit meinem Code.
Die Abspeicherung funktioniert, aber die Funktion Email Erinnerung leider nicht.
Bitte zeigen Sie folgenden Code unten an:

Code:

Private Sub workbook_open()
    Dim strVerzeichnis As String
    Dim strDateiname As String
    Dim strVerzeichnis1 As String
    Dim strDateiname1 As String
    Dim Pfad As String
    Pfad = "G:\OfficePro\UM-QM TS 16949\Interne_Dokumente\Formulare\Formulare leer\Hauptprozesse\in_Bearbeitung\"
    strVerzeichnis1 = "C:\Users\Public\"
    strVerzeichnis = ThisWorkbook.Path
        
    If Dir(Pfad, vbDirectory) <> "" Then
        Select Case strDateiname1 = Application.GetSaveAsFilename(InitialFileName:=strVerzeichnis1 & _
        "FO-H10_Projektablaufplan Meilensteine_" & Range("C2").Formula & Format(Year(Date), "00") & Format(Month(Date), "00") & Format(Day(Date), "00"), _
        FileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsm), *.xlsm")
            Case False
                Exit Sub
        End Select
    Else
        Select Case strDateiname = Application.GetSaveAsFilename(InitialFileName:=strVerzeichnis & "\" & _
        "FO-H10_Projektablaufplan Meilensteine_" & Range("C2").Formula & "_" & Format(Year(Date), "00") & Format(Month(Date), "00") & Format(Day(Date), "00"), _
        FileFilter:="Microsoft Excel-Arbeitsmappe (*.xlsm), *.xlsm")
            Case False
                Exit Sub
        End Select
    End If
    
MsgBox ("Achtung! Vor jeder Bearbeitung Meilensteintermine prüfen und ggfs. anpassen. Termine immer in den Meilenstein-Tabellenblättern im dafür vorgesehenen Feld aktualisieren!")
 
 Dim rCell As Range
    Dim objApp As Object
    Dim objMailItm As Object
    Dim tBRng As String
    Dim tReceiver As String
    
    tBRng = "A7:A" & Sheets("LoP").UsedRange.Rows.Count
   tReceiver = Sheets("Kopfdaten").Range("C10:C30")- [color=#ff3333]Emailadresse[/color]
[color=#ff3333]    [/color]
    Set objApp = CreateObject("Outlook.Application")
    For Each rCell In Sheets("LoP").Range(tBRng)
        If IsDate(rCell.Offset(0, 8).Value) Then
            If rCell.Offset(0, 8) - Date <= Sheets("LoP").Range("L5").Value _
                And Not (rCell.Offset(0, 11).Value) Then
                Set objMailItm = objApp.CreateItem(0)
                With objMailItm
                    .BCC = tReceiver
                    .Subject = "Fälligkeitswarnung Projekt-LoP"
                    .Body = "Das Thema <" & _
                            rCell.Offset(0, 4).Value & ">" & vbCrLf & _
                            "unter der lfd. Nr.: " & rCell.Offset(0, 0).Value & vbCrLf & _
                            "wird am " & rCell.Offset(0, 8).Value & " fällig!" & vbCrLf & _
                            "Verantwortlich: " & rCell.Offset(0, 1).Value
                    .Send
                End With
                rCell.Offset(0, 11).Value = True
                Set objMailItm = Nothing
            End If
        End If
    Next
Set objApp = Nothing
End Sub

Vielen Dank für jedes Antwort.

Gruß
Karolina

[steve1da]

Hola,

zur Info...

http://www.vba-forum.de/forum/View.aspx?...Erinnerung

Gruß,
steve1da