(
Anhgolden's Blog)-Mặc định trong Mail Merge của Outlook không cho phép đính kèm file và bổ sung phần CC và BCC. Tôi xin chia sẻ dùng VB Script để bổ sung 2 tính năng này.
Bước 1: Để Outlook ở chế độ Work Offline (Outlook Menu File - Work Offline). Mục đích các email sau khi hoàn tất sẽ nằm tại "Outbox" và chỉ khi nào ta chủ động Click "Send and Receive" thì email mới được gửi.
Bước 2: Double click vào file VB Script tương ứng:
Outlook-Mail-Merge-add-Attachment.vbs
Outlook-Mail-Merge-add-CC-and-BCC.vbs
' Outlook Mail Merge Attachment
'
'
SubOutlookMailMergeAttachment
Sub SubOutlookMailMergeAttachment
' Script version
strProgamName = "Outlook Mail Merge add C/C and BCC"
strProgamVersion = "Outlook Mail Merge add C/C and BCC"
' Set manual line-breaks in message box texts for windoes versions < 6.
strBoxCr = vbCrLf
On Error Resume Next
Set SystemSet = GetObject("winmgmts:").InstancesOf ("Win32_OperatingSystem")
For each System in SystemSet
If System.Version >= 6 Then
strBoxCr = ""
End If
sWindowsVersion = System.Caption
Next
On Error Goto 0
' Outlook and Word Constants
intFolderOutbox = 4
msoFileDialogOpen = 1
' Load requied objects
Set WshShell = WScript.CreateObject("WScript.Shell") ' Windows Shell
Set ObjWord = CreateObject("Word.Application") ' File Open dialog
Set ObjOlApp = CreateObject("Outlook.Application") ' Outlook
Set ns = ObjOlApp.GetNamespace("MAPI") ' Outlook
Set box = ns.GetDefaultFolder(intFolderOutbox) ' Outlook
' Check if we can detect problems in the outlook configuration
sProblems = ""
sBuild = Left(ObjOlApp.Version, InStr(1, ObjOlApp.Version, ".") + 1)
' check spelling check just before sending
On Error Resume Next
r = WshShell.RegRead("HKCU\Software\Microsoft\Office\" & sBuild & "\Outlook\Options\Spelling\Check")
If Not(Err) And (r = 1) Then
sProblems = sProblems & _
"Your Outlook spell check is configured such that it gives a pop-up box when sending emails. Please disable " & strBoxCr & _
"the 'Always check spelling before sending' option in your Outlook. (ErrorCode = 101)" & vbCrLf &vbCrLf
End If
On Error Goto 0
' For outlook 2000, 2002, 2003
If sBuild = "9.0" Or sBuild = "10.0" Or sBuild = "11.0" Then
' Check for word as email editor.
On Error Resume Next
intEditorPrefs = WshShell.RegRead("HKCU\Software\Microsoft\Office\" & sBuild & "\Outlook\Options\Mail\EditorPreference")
If Not(Err) Then
If intEditorPrefs = 131073 Or intEditorPrefs = 196609 Or intEditorPrefs = 65537 Then
' HTML = 131072, HTML & Word To Edit = 131073, Rich Text = 196610, Rich Text & Word To Edit = 196609, Plain Text = 65536, Plain Text & Word To Edit = 65537
sProblems = sProblems & _
"Your Outlook is configured to use Word as email editor. Please change this to the internal outlook editor in " & strBoxCr & _
"your outlook settings. (ErrorCode = 102)" & vbCrLf &vbCrLf
End If
End If
On Error Goto 0
End If
If sProblems <> "" Then
sProblems = "The OMMA scirpt detected settings in your Outlook settings that need to be changed for the software to work." & vbCrLf & vbCrLf & sProblems
MsgBox sProblems, vbExclamation, strProgamName
'fout
Exit Sub
End If
' Check if there are messages
If box.Items.Count = 0 Then
MsgBox "There are no messages in the Outbox.", vbExclamation, strProgamName
' fout
Exit Sub
End If
' Give a warning if there already is an ment
If box.Items(1).Attachments.Count > 0 Then
If MsgBox("The first email in your outbox has already " & box.Items(1).Attachments.Count & " attatchment(s). Do you want to continue?", vbOKCancel + vbQuestion, strProgamName) = vbCancel Then
' fout
Exit Sub
End If
End If
' Ask user to open a file
' Select the attachment filename
WScript.Sleep(800)
'''''''''''''''''''''''''''''''''''''''''''''''
' Modify for CC and BCC
'''''''''''''''''''''''''''''''''''''''''''''''
For Each Item In box.Items
'Item.Recipients.Add("abc@mail.com")
Item.Cc = "abc@mail.com" 'Bo dung ds email cach nhau bang dau;
Item.Bcc = "xyz@mail.com" 'Bo dung ds email cach nhau bang dau;
'Item.Attachments.Add(FileName)
Item.Save
Next
'''''''''''''''''''''''''''''''''''''''''''''''
' Send the emails using keystrokes
'''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 to box.Items.Count
' Open email
Set objItem = box.Items(i)
Set objInspector = objItem.GetInspector
objInspector.Activate
WshShell.AppActivate(objInspector.Caption)
objInspector.Activate
' wait upto 10 seconds until the window has focus
okEscape = False
For j = 1 To 100
WScript.Sleep(100)
If (objInspector Is ObjOlApp.ActiveWindow) Then
okEscape = True
Exit For
End If
Next
If Not(okEscape) Then
MsgBox "Internal error while opening email in outbox. Please read the how-to and the troubleshooting sections in the " & strBoxCr & "documentation. (ErrorCode = 103)", vbError, strProgamName
' fout
Exit Sub
End If
' send te email by typing ALT+S
WshShell.SendKeys("%S")
' wait upto 10 seconds for the sending to complete
okEscape = False
For j = 1 To 100
WScript.Sleep(100)
boolSent = False
On Error Resume Next
boolSent = objItem.Sent
If Err Then
boolSent = True
End If
On Error Goto 0
If boolSent Then
okEscape = True
Exit For
End If
Next
If Not(okEscape) Then
' Error
MsgBox "Internal error while sending email. Perhaps the email window was not activated. Please read the how-to and " & strBoxCr & "the troubleshooting sections in the documentation. (ErrorCode = 104)", vbExclamation, strProgamName
' fout
Exit Sub
End If
Next
End Sub
Lưu ý:
Trong file Outlook-Mail-Merge-add-CC-and-BCC.vbs, nên sửa lại phần sau theo nhu cầu:
For Each Item In box.Items
'Item.Recipients.Add("abc@mail.com")
Item.Cc = "abc@mail.com" 'Bo dung ds email cach nhau bang dau;
Item.Bcc = "xyz@mail.com" 'Bo dung ds email cach nhau bang dau;
'Item.Attachments.Add(FileName)
Item.Save
Next
Chương trình sẽ bổ sung phần Attachment và CC, BCC vào các email đang nằm trong "Outbox" (ở bước 1)
Bước 3: Chính thức Click "Send and Receive" và chuyển lại chế độ Work Online theo nhu cầu.
