I had this code which work pretty well from this user here.
https://www.mrexcel.com/forum/excel...end-emails-attachment-base-path-folder-4.html
But need someone to help.
Possible to move send email to ARCHIVE Folder once email sent on outlook
In outlook, there is a SAVE SENT ITEM TO XX folder
Can i save sent in my ARCHIVE Folder?
Main: 2019_ARCHIVE
Subfolder: SendFolder
https://www.mrexcel.com/forum/excel...end-emails-attachment-base-path-folder-4.html
But need someone to help.
Possible to move send email to ARCHIVE Folder once email sent on outlook
In outlook, there is a SAVE SENT ITEM TO XX folder
Can i save sent in my ARCHIVE Folder?
Main: 2019_ARCHIVE
Subfolder: SendFolder
Code:
Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, d As Long
Dim wks As Worksheet, pf As String, wPath As String, wFile As Variant, wPattern As String
Dim num_err As Variant, sErr As Boolean
'START of confirmation message box'
response = MsgBox("Start sending email?", vbYesNo)
If response = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'
Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("SendEmail")
lr = wks.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
sErr = False
With Mail_Object.CreateItem(o)
.to = wks.Range("B" & i).Value
.cc = wks.Range("C" & i).Value
.Subject = wks.Range("D" & i).Value
.Body = wks.Range("E" & i).Value & vbNewLine & _
wks.Range("F" & i).Value & vbNewLine & _
wks.Range("G" & i).Value
pf = wks.Range("H" & i).Value
d = InStrRev(pf, "\")
wPath = Left(pf, d)
wPattern = Mid(pf, d + 1)
If wPath <> "" Then
If wPattern = "" Then wPattern = "*.*"
'If Right(wPath, 1) <> "\" Then wPath = wPath & "\"
If Dir(wPath, vbDirectory) <> "" Then
wFile = Dir(wPath & wPattern)
On Error Resume Next
If wFile <> "" Then
Do While wFile <> ""
.Attachments.Add wPath & wFile
num_error = Err.Number
If num_error <> 0 Then
wks.Range("I" & i).Value = "ERROR Exceed Size"
sErr = True
End If
wFile = Dir()
Loop
Else
wks.Range("I" & i).Value = "ERROR Wrong File URL"
sErr = True
End If
On Error GoTo 0
Else
wks.Range("I" & i).Value = "ERROR Wrong Folder URL"
sErr = True
End If
End If
If sErr = False Then
.Send
'.display 'disable display and enable send to send automatically
num_error = Err.Number
If num_error <> 0 Then
wks.Range("I" & i).Value = Err.Description
Else
wks.Range("I" & i).Value = "Email Send!"
End If
End If
Application.Wait (Now + TimeValue("0:00:07")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub