Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Makro Abspeicherung mit Email Erinnerung Funktion
#1
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
Antworten Top
#2
Hola,

zur Info...

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

Gruß,
steve1da
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste