Salve ha tutti sono nuovo è poco pratico di VBA e macro,
ho provato questa formula e altre per inviare una email automaticamente in scadenza di una data.
ma non funziona.
sbaglio sicuramente qualcosa.
Mi può aiutare qualcuno.
ho eseguito come detto varie prove prese su questo forum ma nulla non funzionano.
poi vorrei sapere se questa macro deve calcolare la data di scadenza, deve capire la data odierna , che sicuramente deve essere scritta in una riga di questa vba vero?
Grazie per l'aiuto saluti.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:"
,
"KuTools For Excel"
, , , , , , 8)
If
xRgDate
Is
Nothing
Then
Exit
Sub
Set
xRgSend = Application.InputBox(
"Please select the recipients?email column:"
,
"KuTools For Excel"
, , , , , , 8)
If
xRgSend
Is
Nothing
Then
Exit
Sub
Set
xRgText = Application.InputBox(
"Select the column with reminded content in your email:"
,
"KuTools 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