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!
'
' "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).
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
