Outlook - Macro to resend email automatically....

Asked By Nishikant on 26-Jul-11 03:52 AM
I need a vbscript to resend the email automatically by reading the address of a particular emailid as sson as any mail comes to my inbox from that specified person. As soon as the mail comes the macro needs to read the emailaddress, verifies it and accordingly resend the message but the condition is that it should replace the originating address with my emailid.
Anoop S replied to Nishikant on 26-Jul-11 04:09 AM

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!

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

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

Jitendra Faye replied to Nishikant on 26-Jul-11 04:31 AM

Follow this code-

' -- Begin Code  Here --
Option Explicit

' Declare module level variables
Dim mOutlookApp As Outlook.Application
Dim mNameSpace As Outlook.NameSpace
Dim mFolder As MAPIFolder
Dim mItem As MailItem
Dim fSuccess As Boolean

' Module contains only 2 methods:  
'    1) GetOutlook() 
'    2) SendMessage() 
'
Private Function GetOutlook() As Boolean
' The GetOutlook() function sets the Outlook Application 
' and Namespase objects and opens MS Outlook
On Error Resume Next

' Assume success
fSuccess = True

Set mOutlookApp = GetObject("", "Outlook.application")

' If Outlook is NOT Open, then there will be an error. 
' Attempt to open Outlook
If Err.Number > 0 Then
    Err.clear
    Set mOutlookApp = CreateObject("Outlook.application")
        
    If Err.Number > 0 Then
        MsgBox "Could not create Outlook object", vbCritical
        fSuccess = False
        Exit Function
    End If
End If

' If we've made it this far, we have an Outlook App Object 
' Now, set the NameSpace object to MAPI Namespace
Set mNameSpace = mOutlookApp.GetNamespace("MAPI")
    
If Err.Number > 0 Then
    MsgBox "Could not create NameSpace object", vbCritical
    fSuccess = False
    Exit Function
End If

' Return the Success Flag as the value of GetOutlook()
GetOutlook = fSuccess
    
End Function


Public Function SendMessage() As Boolean
' The SendMessage() function reads user entered values and
' actually sends the message.

On Error Resume Next

Dim strRecip As String
Dim strSubject As String
Dim strMsg As String
Dim strAttachment As String

strSubject = Me!txtSubject
strRecip = Me!txtRecipient
strMsg = Me!txtBody
strAttachment = Me!txtAttachment

' Any amount of validation could be done at this point, but
' at a minimum, you need to verify that the user supplied an
' Email address for a recipient.
If Len(strRecip) = 0 Then
    strMsg = "You must designate a recipient."
    MsgBox strMsg, vbExclamation, "Error"
    Exit Function
End If

' Assume success
fSuccess = True

' Here's where the real Outlook Automation takes place
If GetOutlook = True Then
    Set mItem = mOutlookApp.CreateItem(olMailItem)
    mItem.Recipients.Add strRecip
    mItem.Subject = strSubject
    mItem.Body = strMsg
    
    ' This code allows for 1 attachment, but with slight 
    ' modification, you could provide for multiple files.
    If Len(strAttachment) > 0 Then
        mItem.Attachments.Add strAttachment
    End If
    
    mItem.Save
    mItem.Send
End If

' Release resources
Set mOutlookApp = Nothing
Set mNameSpace  = Nothing

If Err.Number > 0 Then fSuccess = False
SendMessage = fSuccess

End Function
' -- End Code Here -->


Follow this link-

http://www.serverwatch.com/tutorials/article.php/1474711/Send-E-mail-Using-Microsoft-Outlook-Automation.htm

Radhika roy replied to Nishikant on 26-Jul-11 11:17 AM

follow this marco code-

Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
      Dim objOutlook As Outlook.Application
      Dim objOutlookMsg As Outlook.MailItem
      Dim objOutlookRecip As Outlook.Recipient
      Dim objOutlookAttach As Outlook.Attachment

      ' Create the Outlook session.
      Set objOutlook = CreateObject("Outlook.Application")

      ' Create the message.
      Set objOutlookMsg  = objOutlook.CreateItem(olMailItem)

      With objOutlookMsg
        ' Add the To recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
        objOutlookRecip.Type = olTo

        ' Add the CC recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("Michael Suyama")
        objOutlookRecip.Type = olCC

       ' Add the BCC recipient(s) to the message.
        Set objOutlookRecip = .Recipients.Add("Andrew Fuller")
        objOutlookRecip.Type = olBCC

       ' Set the Subject, Body, and Importance of the message.
       .Subject = "This is an Automation test with Microsoft Outlook"
       .Body = "This is the body of the message." &vbCrLf & vbCrLf
       .Importance = olImportanceHigh  'High importance

       ' Add attachments to the message.
       If Not IsMissing(AttachmentPath) Then
         Set objOutlookAttach = .Attachments.Add(AttachmentPath)
       End If

       ' Resolve each Recipient's name.
       For Each ObjOutlookRecip In .Recipients
         objOutlookRecip.Resolve
       Next

       ' Should we display the message before sending?
       If DisplayMsg Then
         .Display
       Else
         .Save
         .Send
       End If
      End With
      Set objOutlook = Nothing
    End Sub

also follow this link-

http://support.microsoft.com/kb/161088

Hope this will help you.