carloschouw
Gebruiker
- Lid geworden
- 15 jun 2015
- Berichten
- 225
Goedemiddag,
Ik heb een vraagje over een emailfunctie wanneer er een cel niet ingevuld is en er een datum verstreken is. Onderstaand kwam ik een code tegen zoiets dergelijks zou kunnen doen echter zoek ik iets om dit uit voeren bij losse, gesloten Excel mappen.
Voorbeeld waar ik naar op zoek ben:
- Invul Excel bestand (bijlage) is Map1.xls Hierin moet je een datum invullen. Wanneer iemand het bestand opslaat zónder invullen van een datum dan zou de volgende dag (of 2, 3 dagen later) een email verzonden moeten worden dat men in deze map vergeten is een datum in te vullen. De opgeslagen map zonder datum is dan wel gesloten waardoor ik vermoed dat een dergelijke vraag niet mogelijk is?
Ik heb een vraagje over een emailfunctie wanneer er een cel niet ingevuld is en er een datum verstreken is. Onderstaand kwam ik een code tegen zoiets dergelijks zou kunnen doen echter zoek ik iets om dit uit voeren bij losse, gesloten Excel mappen.
Voorbeeld waar ik naar op zoek ben:
- Invul Excel bestand (bijlage) is Map1.xls Hierin moet je een datum invullen. Wanneer iemand het bestand opslaat zónder invullen van een datum dan zou de volgende dag (of 2, 3 dagen later) een email verzonden moeten worden dat men in deze map vergeten is een datum in te vullen. De opgeslagen map zonder datum is dan wel gesloten waardoor ik vermoed dat een dergelijke vraag niet mogelijk is?
Code:
Public Sub CheckAndSendMail()
'Updated by Extendoffice 2018/11/22
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 = Application.InputBox("Please select the due date column:", "***ools For Excel", , , , , , 8)
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Application.InputBox("Please select the recipients?email column:", "***ools For Excel", , , , , , 8)
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "***ools For Excel", , , , , , 8)
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 <= 7 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = xRgText.Offset(i - 1).Value & " on " & xRgDateVal
vbCrLf = "<br><br>"
xMailBody = "<HTML><BODY>"
xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
xMailBody = xMailBody & "Text : " & 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
