|
Hallo Zusammen,
Kann mir vielleicht jemand mit menem Code helfen?
Es geht um die Abspeicherung Funktion und eine Email Erinnerung wenn ein Datum überschritten würde.
Die Abspeicherung funktioniert aber die Erinnerung funktion leider nicht.
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")---- Die Liste mit Emailadresse
Set objApp = CreateObject("Outlook.Application")
For Each rCell In Sheets("LoP").Range(tBRng)
If IsDate(rCell.Offset(0, 8).Value) Then----- Die Datums
If rCell.Offset(0, 8) - Date <= Sheets("LoP").Range("L5").Value ------ L5 = 7 TAge
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
Gruß Karolina
|