Resend This Message
How to assign a macro to a toolbar button
Outlook Code to resend messages
The following VBA code, placed in a standard module in the Outlook VBE, can be run on-demand via a toolbar button to execute the "Resend This Message…" function on the Actions menu of an open email.
As most Outlook users know, you can open a sent email and click "Resend This Message…" on the Actions menu. This constructs a copy of the original email as if you were sending it again, with the original body, To and Cc preserved. All you have to do is fill in the subject, change a few relevant details and click Send. This method is perfect if you are sending the same email every day or every week to the same recipients and you are just updating a few minor details, like a weekly status report.
Just like some of the other Outlook code found here, you can also run it from the Explorer window, it will simply act on the currently selected email. Don't select or open more than one message before running this code. If you do run it from the Explorer window, it temporarily opens the email, then closes it at the end, so you will see the screen flash a bit.
One thing this code does which "Resend This Message…" doesn't do is pull the original subject line into the new email!
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | Sub ResendMsg() ' ' "Resend This Message..." functionality ' Dim myItem As Outlook.MailItem Dim objInsp As Outlook.Inspector Dim objActionsMenu As Office.CommandBarControl Dim olNewMailItem As Outlook.MailItem ' get valid ref to current item On Error Resume Next Select Case TypeName(Application.ActiveWindow) Case "Explorer" Set myItem = ActiveExplorer.Selection.Item(1) myItem.Display Case "Inspector" Set myItem = ActiveInspector.CurrentItem Case Else End Select On Error GoTo 0 If myItem Is Nothing Then MsgBox "Could not use current item. Please select or open a single email.", _ vbInformation GoTo exitproc End If ' find "Resend This Message" control Set objInsp = ActiveInspector Set objActionsMenu = objInsp.CommandBars.FindControl(, 3165) ' resend message objActionsMenu.Execute ' get object reference to new mail to play with it Set olNewMailItem = ActiveInspector.CurrentItem olNewMailItem.Subject = myItem.Subject ' close orig email myItem.Close olDiscard exitproc: Set myItem = Nothing Set objInsp = Nothing Set objActionsMenu = Nothing Set olNewMailItem = Nothing End Sub |
How to assign a macro to a toolbar button
While viewing an email or in the main Explorer window, hover your mouse pointer over a toolbar, right-click and choose 'Customize'. Or go to View>Toolbars>Customize. On the "Commands" tab, in the "Categories" list, click "Macros." The list of macros you created should appear.
Click and drag the appropriate macro to the toolbar of your choice. If you are in the main Explorer window, this would either be the Standard or Advanced toolbar. If you are viewing a email, it would be either the Standard or Formatting toolbar.
Once you drop the macro on the toolbar, right-click it and customize the display name, icon, etc.
You might be wondering how I figured out the ID number of the "Resend This Message…" control. The following code, placed in a standard module in Excel, will produce a workbook showing all of the control IDs and names for every control available to the Explorer and Inspector objects. Remember to set an object reference to the Outlook object library (see the Binding page for instructions).
Please note I did not write the code below, it was taken from this Microsoft KB article. (Yes that is Microsoft written code with all those globals).
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | Dim oOutApp As Outlook.Application Dim I As Long Dim iRowCount As Long Dim oItm As Object ' so it'll handle varying item types Dim oSheet As Excel.Worksheet Dim oNS As Outlook.NameSpace Dim oFld As Outlook.MAPIFolder Sub GetOutlookCommandBarIDs() If MsgBox("This will clear the current worksheet, OK to continue?", vbOKCancel) = 1 Then Cells.Select Selection.ClearContents iRowCount = 0 Set oSheet = ActiveSheet Set oOutApp = New Outlook.Application Set oNS = oOutApp.Session Set oItm = oOutApp.CreateItem(olMailItem) GetInspectorIDs oItm, "Mail Message" Set oItm = oOutApp.CreateItem(olPostItem) GetInspectorIDs oItm, "Post" Set oItm = oOutApp.CreateItem(olContactItem) GetInspectorIDs oItm, "Contact" Set oItm = oOutApp.CreateItem(olDistributionListItem) GetInspectorIDs oItm, "Distribution List" Set oItm = oOutApp.CreateItem(olAppointmentItem) GetInspectorIDs oItm, "Appointment" Set oItm = oOutApp.CreateItem(olTaskItem) GetInspectorIDs oItm, "Task" Set oItm = oOutApp.CreateItem(olJournalItem) GetInspectorIDs oItm, "Journal Entry" Set oFld = oNS.GetDefaultFolder(olFolderInbox) GetExplorerIDs oFld, "Mail Folder" Set oFld = oNS.GetDefaultFolder(olFolderContacts) GetExplorerIDs oFld, "Contact Folder" Set oFld = oNS.GetDefaultFolder(olFolderCalendar) GetExplorerIDs oFld, "Calendar Folder" Set oFld = oNS.GetDefaultFolder(olFolderTasks) GetExplorerIDs oFld, "Task Folder" Set oFld = oNS.GetDefaultFolder(olFolderJournal) GetExplorerIDs oFld, "Journal Folder" Set oFld = oNS.GetDefaultFolder(olFolderNotes) GetExplorerIDs oFld, "Notes Folder" Selection.AutoFilter Cells.Select Cells.EntireColumn.AutoFit Range("A1").Select MsgBox "The spreadsheet is complete." End If End Sub Sub GetInspectorIDs(oItm, sType As String) Dim oCBs As Office.CommandBars Dim oCtl As Office.CommandBarControl Set oCBs = oItm.GetInspector.CommandBars For I = 1 To 35000 Set oCtl = oCBs.FindControl(, I) If Not (oCtl Is Nothing) Then iRowCount = iRowCount + 1 oSheet.Cells(iRowCount, 1) = "Inspector" oSheet.Cells(iRowCount, 2) = sType oSheet.Cells(iRowCount, 3) = oCtl.Parent.Name oSheet.Cells(iRowCount, 4) = oCtl.Caption oSheet.Cells(iRowCount, 5) = CStr(I) End If Next End Sub Sub GetExplorerIDs(oFld As Outlook.MAPIFolder, sType As String) Dim oCBs As Office.CommandBars Dim sFilter As String Dim oCtl As Office.CommandBarControl Set oCBs = oFld.GetExplorer.CommandBars For I = 1 To 35000 Set oCtl = oCBs.FindControl(, I) If Not (oCtl Is Nothing) Then iRowCount = iRowCount + 1 oSheet.Cells(iRowCount, 1) = "Explorer" oSheet.Cells(iRowCount, 2) = sType oSheet.Cells(iRowCount, 3) = oCtl.Parent.Name oSheet.Cells(iRowCount, 4) = oCtl.Caption oSheet.Cells(iRowCount, 5) = CStr(I) End If Next End Sub |
Buy Chandoo's Excel Formula E-book



