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