Clever-Excel-Forum

Normale Version: Makro Abspeicherung mit Email Erinnerung Funktion
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.
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