|
Hallo zusammen,
mit kleineren Makros und deren Aufzeichnungen habe ich mich in der Vergangenheit bereits beschäftigt. Oftmals erlese ich in Foren mir meine Lösungsansetze.
Zum Problem:
Ich möchte in einer Exceltabelle eine automatische Abfrage zum Ablaufdatum von verschiedenen Produkten tätigen.
Soll heißen, dass innerhalb eines bestimmten und durch mich festgelegten Zeitfenster (in Tagen), eine Information zur Haltbarkeit und den verbleibenden Tagen bis zum Ablauf, mittels generierter email versendet wird.
Dieses ist mir durch das anpassen meines ersten Makros auch gelungen.
Ich erhalte eine Information über Outlook, dass in den Tagen „x“ ein Produkt abläuft und ersetzt werden soll.
Jetzt habe ich aber in einem anderen Forum gesucht, um diese Abläufe des Makros innerhalb von IBM Lotus notes zu ermöglichen.
Hierzu habe ich ein zweites Makro entdeckt. Ich bin aber völlig ahnungslos, wie es mir gelingen kann, beide innerhalb eines Prozesses zu verpacken.
Also die Auswertung über das Erreichen des Ablaufdatums soll wie im ersten Makro (Microsoft Outlook) über IBM lotus notes erfolgen.
Hat jemand bitte einen Lösungsvorschlag für mich?
Vielen dank...
ublic Sub CheckAndSendMail()
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim i As Long
On Error Resume Next
Set xRgDate = Range("D5: D38") d5 bis d38__ Angabe vom Verwalldatum
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Range("f5") f5___ emailadresse
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Range("A5: A38") A5:A38__ Produkt
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 14 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = xRgText.Offset(i - 1).Value & " verfällt am: " & xRgDateVal
vbCrLf = "<br><br>"
xMailBody = "<HTML><BODY>"
xMailBody = xMailBody & "Hallo Kollegen ! Das folgende Medizinprodukt muss im Rettungsrucksack muss ersetzt werden;"
xMailBody = xMailBody & "Medizinprodukt:" & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & "</BODY></HTML>"
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.HTMLBody = xMailBody
.Display
.Send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
End Sub
|