Option Explicit
'====================================================================
' INTERVIEW LETTER AUTOMATION
'
' Excel -> Word Mail Merge -> Individual PDF
' -> Same Personalized Letter in Outlook Email Body
' -> Attach PDF -> Draft / Send
'====================================================================
'====================================================================
' SETTINGS
'====================================================================
Const PDF_FOLDER As String = "E:\Interview Letters\"
'False = Save in Outlook Drafts
'True = Send automatically
Const AUTO_SEND As Boolean = False
'====================================================================
' EXCEL FIELD NAMES
'====================================================================
Const FIELD_SL As String = "SL"
Const FIELD_EMAIL As String = "Email"
Const FIELD_ROLL As String = "Roll"
Const FIELD_POST As String = "Post"
Const FIELD_NAME As String = "Name"
Const FIELD_DEPT As String = "Dept"
Const FIELD_MESSAGE As String = "Message"
Const FIELD_ADDRESS As String = "Address"
Const FIELD_DESPATCH As String = "Despatch"
Const FIELD_SUBJECT As String = "Subject"
'====================================================================
' MAIN PROCEDURE
'====================================================================
Sub GenerateInterviewLettersAndEmails()
Dim MainDoc As Document
Dim MergeDoc As Document
Dim MM As MailMerge
Dim DS As MailMergeDataSource
Dim TotalRecords As Long
Dim i As Long
Dim SL As String
Dim CandidateEmail As String
Dim CandidateRoll As String
Dim CandidatePost As String
Dim CandidateName As String
Dim CandidateDept As String
Dim CandidateMessage As String
Dim CandidateAddress As String
Dim CandidateDespatch As String
Dim EmailSubject As String
Dim PDFFileName As String
Dim PDFPath As String
Dim SuccessCount As Long
Dim ErrorCount As Long
Dim ErrorLog As String
Dim ModeText As String
Dim ResultMessage As String
'================================================================
' CHECK MAIL MERGE DOCUMENT
'================================================================
If ActiveDocument.MailMerge.MainDocumentType = _
wdNotAMergeDocument Then
MsgBox _
"The active document is not a Word Mail Merge document." & _
vbCrLf & vbCrLf & _
"Please open the Mail Merge main document and run " & _
"the macro again.", _
vbCritical, _
"Mail Merge Error"
Exit Sub
End If
'================================================================
' CHECK PDF FOLDER
'================================================================
If Dir(PDF_FOLDER, vbDirectory) = "" Then
MsgBox _
"The PDF folder does not exist:" & _
vbCrLf & vbCrLf & _
PDF_FOLDER & _
vbCrLf & vbCrLf & _
"Please create the folder or change PDF_FOLDER " & _
"in the VBA code.", _
vbCritical, _
"Folder Not Found"
Exit Sub
End If
'================================================================
' SET MAIL MERGE OBJECTS
'================================================================
Set MainDoc = ActiveDocument
Set MM = MainDoc.MailMerge
Set DS = MM.DataSource
TotalRecords = DS.RecordCount
If TotalRecords < 1 Then
MsgBox _
"No Mail Merge records were found.", _
vbExclamation, _
"No Records"
Exit Sub
End If
'================================================================
' CONFIRM OPERATION
'================================================================
If AUTO_SEND = True Then
ModeText = "WARNING: Emails will be SENT automatically."
Else
ModeText = "Emails will be saved in Outlook Drafts."
End If
If MsgBox( _
"Total candidates: " & TotalRecords & _
vbCrLf & vbCrLf & _
"The macro will automatically:" & _
vbCrLf & vbCrLf & _
"1. Merge each candidate separately." & vbCrLf & _
"2. Generate an individual PDF." & vbCrLf & _
"3. Create an Outlook email." & vbCrLf & _
"4. Use the same merged letter as the email body." & vbCrLf & _
"5. Attach the corresponding PDF." & vbCrLf & _
"6. Use the Subject field from Excel." & vbCrLf & _
"7. " & ModeText & _
vbCrLf & vbCrLf & _
"Do you want to continue?", _
vbYesNo + vbQuestion, _
"Interview Letter Automation") <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'================================================================
' PROCESS EACH CANDIDATE
'================================================================
For i = 1 To TotalRecords
'Clear previous values
SL = ""
CandidateEmail = ""
CandidateRoll = ""
CandidatePost = ""
CandidateName = ""
CandidateDept = ""
CandidateMessage = ""
CandidateAddress = ""
CandidateDespatch = ""
EmailSubject = ""
On Error GoTo CandidateError
'------------------------------------------------------------
' SELECT CURRENT RECORD
'------------------------------------------------------------
DS.ActiveRecord = i
'------------------------------------------------------------
' READ EXCEL FIELDS
'------------------------------------------------------------
SL = Trim(CStr(DS.DataFields(FIELD_SL).Value))
CandidateEmail = _
Trim(CStr(DS.DataFields(FIELD_EMAIL).Value))
CandidateRoll = _
Trim(CStr(DS.DataFields(FIELD_ROLL).Value))
CandidatePost = _
Trim(CStr(DS.DataFields(FIELD_POST).Value))
CandidateName = _
Trim(CStr(DS.DataFields(FIELD_NAME).Value))
CandidateDept = _
Trim(CStr(DS.DataFields(FIELD_DEPT).Value))
CandidateMessage = _
Trim(CStr(DS.DataFields(FIELD_MESSAGE).Value))
CandidateAddress = _
Trim(CStr(DS.DataFields(FIELD_ADDRESS).Value))
CandidateDespatch = _
Trim(CStr(DS.DataFields(FIELD_DESPATCH).Value))
'IMPORTANT:
'Read Bangla subject directly from Excel/Mail Merge source.
EmailSubject = _
Trim(CStr(DS.DataFields(FIELD_SUBJECT).Value))
'================================================================
' VALIDATION
'================================================================
If CandidateEmail = "" Then
Err.Raise _
vbObjectError + 1000, , _
"Email address is blank."
End If
If InStr(1, CandidateEmail, "@") = 0 Then
Err.Raise _
vbObjectError + 1001, , _
"Invalid email address: " & CandidateEmail
End If
If CandidateName = "" Then
Err.Raise _
vbObjectError + 1002, , _
"Candidate name is blank."
End If
If CandidateRoll = "" Then
Err.Raise _
vbObjectError + 1003, , _
"Candidate Roll is blank."
End If
If EmailSubject = "" Then
Err.Raise _
vbObjectError + 1004, , _
"Email Subject is blank."
End If
'================================================================
' CREATE PDF FILE NAME
'
' Example:
' 101_Candidate Name.pdf
'================================================================
PDFFileName = _
CleanFileName( _
CandidateRoll & "_" & _
CandidateName & _
".pdf")
PDFPath = PDF_FOLDER & PDFFileName
'================================================================
' MERGE CURRENT CANDIDATE ONLY
'================================================================
With MM.DataSource
.FirstRecord = i
.LastRecord = i
End With
MM.Destination = wdSendToNewDocument
MM.SuppressBlankLines = True
'------------------------------------------------------------
' EXECUTE MAIL MERGE
'------------------------------------------------------------
MM.Execute Pause:=False
'------------------------------------------------------------
' NEW PERSONALIZED DOCUMENT
'------------------------------------------------------------
Set MergeDoc = ActiveDocument
'================================================================
' EXPORT PERSONALIZED LETTER TO PDF
'================================================================
MergeDoc.ExportAsFixedFormat _
OutputFileName:=PDFPath, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
'================================================================
' VERIFY PDF
'================================================================
If Dir(PDFPath) = "" Then
Err.Raise _
vbObjectError + 1005, , _
"PDF could not be generated: " & PDFPath
End If
'================================================================
' CREATE OUTLOOK EMAIL
'================================================================
Call CreateOutlookEmail( _
CandidateEmail:=CandidateEmail, _
CandidateRoll:=CandidateRoll, _
CandidatePost:=CandidatePost, _
CandidateName:=CandidateName, _
EmailSubject:=EmailSubject, _
PDFPath:=PDFPath, _
MergeDoc:=MergeDoc)
'================================================================
' CLOSE TEMPORARY MERGED DOCUMENT
'================================================================
MergeDoc.Close SaveChanges:=wdDoNotSaveChanges
Set MergeDoc = Nothing
MainDoc.Activate
SuccessCount = SuccessCount + 1
ContinueLoop:
On Error GoTo 0
Next i
'================================================================
' RESET MAIL MERGE RANGE
'================================================================
On Error Resume Next
MainDoc.Activate
MM.DataSource.FirstRecord = wdDefaultFirstRecord
MM.DataSource.LastRecord = wdDefaultLastRecord
On Error GoTo 0
Application.ScreenUpdating = True
'================================================================
' FINAL REPORT
'================================================================
ResultMessage = _
"Processing completed." & _
vbCrLf & vbCrLf & _
"Total candidates: " & TotalRecords & vbCrLf & _
"Successfully processed: " & SuccessCount & vbCrLf & _
"Errors: " & ErrorCount
If AUTO_SEND = True Then
ResultMessage = _
ResultMessage & _
vbCrLf & vbCrLf & _
"Emails were submitted to Outlook for sending."
Else
ResultMessage = _
ResultMessage & _
vbCrLf & vbCrLf & _
"Emails have been saved in Outlook Drafts."
End If
If ErrorCount > 0 Then
ResultMessage = _
ResultMessage & _
vbCrLf & vbCrLf & _
"ERROR DETAILS:" & _
vbCrLf & _
ErrorLog
End If
MsgBox _
ResultMessage, _
vbInformation, _
"Interview Letter Automation"
Exit Sub
'====================================================================
' ERROR HANDLER
'====================================================================
CandidateError:
ErrorCount = ErrorCount + 1
ErrorLog = _
ErrorLog & _
vbCrLf & _
"Record: " & i & _
" | SL: " & SL & _
" | Roll: " & CandidateRoll & _
" | Name: " & CandidateName & _
" | Email: " & CandidateEmail & _
" | Error: " & Err.Description
On Error Resume Next
If Not MergeDoc Is Nothing Then
MergeDoc.Close SaveChanges:=wdDoNotSaveChanges
Set MergeDoc = Nothing
End If
MainDoc.Activate
On Error GoTo 0
Resume ContinueLoop
End Sub
'====================================================================
' CREATE PERSONALIZED OUTLOOK EMAIL
'====================================================================
Private Sub CreateOutlookEmail( _
ByVal CandidateEmail As String, _
ByVal CandidateRoll As String, _
ByVal CandidatePost As String, _
ByVal CandidateName As String, _
ByVal EmailSubject As String, _
ByVal PDFPath As String, _
ByVal MergeDoc As Document)
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim OutlookInspector As Object
Dim EmailEditor As Object
Dim SourceRange As Range
Dim EmailRange As Object
'================================================================
' CONNECT TO OUTLOOK
'================================================================
On Error Resume Next
Set OutlookApp = _
GetObject(, "Outlook.Application")
On Error GoTo 0
If OutlookApp Is Nothing Then
Set OutlookApp = _
CreateObject("Outlook.Application")
End If
If OutlookApp Is Nothing Then
Err.Raise _
vbObjectError + 2000, , _
"Microsoft Outlook could not be started."
End If
'================================================================
' CREATE EMAIL
'================================================================
Set OutlookMail = _
OutlookApp.CreateItem(0)
'================================================================
' SET EMAIL INFORMATION
'================================================================
With OutlookMail
.To = CandidateEmail
'IMPORTANT:
'EmailSubject was already read from Excel.
'Do NOT try to read DS.DataFields here.
.Subject = EmailSubject
'HTML
.BodyFormat = 2
'Required to access Outlook WordEditor
.Display
End With
'================================================================
' ACCESS OUTLOOK WORD EDITOR
'================================================================
Set OutlookInspector = _
OutlookMail.GetInspector
Set EmailEditor = _
OutlookInspector.WordEditor
'================================================================
' COPY SAME PERSONALIZED WORD LETTER
'================================================================
Set SourceRange = MergeDoc.Content.Duplicate
'Remove final paragraph mark
If SourceRange.End > SourceRange.Start Then
SourceRange.End = SourceRange.End - 1
End If
SourceRange.Copy
'================================================================
' PASTE LETTER INTO EMAIL BODY
'================================================================
Set EmailRange = _
EmailEditor.Range(0, 0)
'16 = Keep original formatting
EmailRange.PasteAndFormat 16
'================================================================
' ATTACH PERSONALIZED PDF
'================================================================
OutlookMail.Attachments.Add PDFPath
'================================================================
' SAVE AS DRAFT OR SEND
'================================================================
If AUTO_SEND = True Then
OutlookMail.Send
Else
OutlookMail.Save
'0 = Save when closing
OutlookMail.Close 0
End If
'================================================================
' CLEAN UP
'================================================================
Set EmailRange = Nothing
Set SourceRange = Nothing
Set EmailEditor = Nothing
Set OutlookInspector = Nothing
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
'====================================================================
' CLEAN INVALID WINDOWS FILE CHARACTERS
'====================================================================
Private Function CleanFileName( _
ByVal FileName As String) As String
Dim InvalidChars As Variant
Dim c As Variant
InvalidChars = Array( _
"\", _
"/", _
":", _
"*", _
"?", _
"""", _
"<", _
">", _
"|")
For Each c In InvalidChars
FileName = _
Replace(FileName, c, "_")
Next c
CleanFileName = FileName
End Function
