Outlook Mail Merge Add Attachment, CC, BCC By VB Script

Có thể bạn quan tâm

Friday, September 21, 2012

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("[email protected]") Item.Cc = "[email protected]" 'Bo dung ds email cach nhau bang dau; Item.Bcc = "[email protected]" '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("[email protected]") Item.Cc = "[email protected]" 'Bo dung ds email cach nhau bang dau; Item.Bcc = "[email protected]" '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. Posted at Friday, September 21, 2012