Outlook Mail Merge add Attachment, CC, BCC by VB Script

(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.