Need to create keystroke macro for Outlook

[Spab23]

Hi there!

Is there any way I can record a keystroke macro in Outlook? I am always forwarding spam to my antispam administrator and I am using the exact same keystrokes each time.

I want to be able to open the offending email, then execute a script that will output:

Alt-V
P
Alt-H
Ctrl-C
Esc
Alt-W
Antispam
Tab Tab Tab
Shift-End
Add to Blacklist
Tab
17 down-arrows
Ctrl-V
Enter
Alt-Enter
Alt-S
Enter
Alt-S
Esc
Y
Ctrl-D

Is this possible in VB or with some other scripting language available within WinXP or Outlook?

Thanks!!

 

[straybullet]

Keytext program will do what you want. I do not know of a free program to do this.

Let them hate - so long as they fear... Lucius Accius

 

[fumei]

You can not record a macro to do, but you ceratinly can write one to do it.

Gerry

 

[Spab23]

Gerry,

What language would I use to write a macro like that? VB? I don't know VB so if you could give me a push in the direction I need, I could find a VB book to fill in the blanks.

Thanks!

 

[fumei]

It can be done in VBA, but I have to warn you, writing for Outlook can be tricky. Post questions here.

Gerry

 

[Spab23]

I have never written a VB or VBA program. I had a copy of "Learn VB6 in 24 hours" lying around the office, but I couldn't even find how to print "Hello" to the screen! The built in help was no help, either.

Can you steer me in the right direction?

Thanks!

 

[BoniR]

hello!
I found this on the internet a while back...you will need to adapt the code for your folders and paths...I didn't write it...just use it...

Option Explicit

' this module will look at the currently open Outlook e-mail message, and then
' it looks up the apparent and real "from" addresses from the Internet headers,
' then generates a new message consisiting of the complete Internet header and the
' body of the original message, and sends it to the "abuse" addresses at the domains
' involved, ie, "abuse@hotmail.com" or "abuse@jackpot.com"
' It will even attempt to parse the header data to create the proper address for
' messages appearing to come from domains like "mail.server.jackpot.com" etc,
' for those, it creates an address like "abuse@jackpot.com" and ignores the additional
' fields before the "whatever.com" part of the domain

' Built for use as a "macro" (VBA module) inside Microsoft Outlook 2003;
' I added it to my Message toolbar you see when viewing an e-mail message
' (NOT the main Outlook application toolbar)
'
' requires References to
'  Microsoft CDO 1.21 library (CDO.DLL)
'  Microsoft Outlook 11 Object Library
'  Microsoft Office 11 Object Library
'
'  Written by Brian Battles WS1O (brian@brianbattles.com)
'
'  I tested it with Outlook 2003 Beta under Windows XP Pro
'
'  No guarantees, warrantees or anything, you're on your own with this!

Public Sub SendSpamComplaintToMailHost()
    ' take current message, grab body text and Internet headers,
    ' and send a copy to the "abuse" address of their mailhost
    '
    ' Modified: 5/17/2003 By BB

    Dim strAddress    As String
    Dim strMailHost   As String
    Dim strSendTo     As String
    Dim strHeaders    As String
    Dim strSender     As String
    Dim strBody       As String
    Dim iPos          As Integer
    Dim ctlCBarCombo  As CommandBarControl
    Dim cbrNewToolbar As CommandBar
    
    On Error GoTo Err_SendSpamComplaintToMailHost
    
    Set cbrNewToolbar = Application.ActiveExplorer.CommandBars.Add(Name:="Status", Position:=msoBarTop, Temporary:=True)
    Set ctlCBarCombo = cbrNewToolbar.Controls.Add(Type:=msoControlEdit)
        With ctlCBarCombo
            .Caption = "Spam Report Sent "
            .Text = "Original Message Deleted"
            .Style = msoComboLabel
            .TooltipText = "Spam Report Sent, Original Message Deleted"
        End With
    cbrNewToolbar.Visible = True
    DoEvents
    strAddress = FromAddress
    iPos = InStr(strAddress, "@")
    strAddress = Right(strAddress, Len(strAddress) - iPos)
    iPos = InStr(strAddress, ".com")
    strSender = CreateAbuseAddress
    strMailHost = Right(strAddress, Len(strAddress) - iPos)
    strSendTo = strSender & ";" & "abuse@" & strAddress & ";" & "postmaster@" & strAddress & ";" & "administrator@" & strAddress
    ' get message's Internet headers
    strHeaders = InternetHeaders
    ' get messages's body
    strBody = GetMessageBody
    strBody = strHeaders & vbCrLf & vbCrLf & vbCrLf & vbCrLf & strBody
    ' send new message containing headers & body to mail host's "abuse" address
    SendNewMessage strSendTo, strBody
    ' delete original message
    DeleteMessage
    ' close original message
    CloseMessage
    'MsgBox "Copy of message sent to sender's mail hosts, and original message deleted" & vbCrLf & vbCrLf & "Look in your 'Sent Mail' folder if you want to see the report you e-mailed", vbInformation, "              Spam Report Sent"
    cbrNewToolbar.Delete
        
Exit_SendSpamComplaintToMailHost:

    On Error GoTo 0
    Exit Sub

Err_SendSpamComplaintToMailHost:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "SendSpamComplaintToMailHost"
            Resume Exit_SendSpamComplaintToMailHost
    End Select
    
End Sub
Private Function FromAddress() As String
    ' Modified: 5/17/2003 By BB

    ' Get the sender's e-mail address
    
    On Error GoTo Err_FromAddress
    
    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objSession As MAPI.Session
    Dim objMsg     As MAPI.Message
    Dim objSender  As MAPI.AddressEntry
    Dim strAddress As String
    Dim strName    As String
    Dim strEntryID As String

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")
    'The ActiveInspector window is the currently active window
    'That is displaying individual Outlook items. Outlook folders
    'are displayed in Explorer windows.
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    'SenderName is the friendly name
    strName = objItem.SenderName
    'We need the EntryID of the item to locate it with CDO
    strEntryID = objItem.EntryID
    'Establish a CDO (MAPI) Session object and logon to it
    Set objSession = CreateObject("MAPI.Session")
    objSession.Logon "", "", False, False
    'Locate the current message with the EntryID using CDO
    Set objMsg = objSession.GetMessage(strEntryID)
    'Get the sender
    Set objSender = objMsg.Sender
    'Get the actual e-mail address
    strAddress = objSender.Address
    FromAddress = strAddress
    'Close MAPI (CDO) Session
    objSession.Logoff

Exit_FromAddress:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objSession Is Nothing) Then
            Set objSession = Nothing
        End If
        If Not (objMsg Is Nothing) Then
            Set objMsg = Nothing
        End If
        If Not (objSender Is Nothing) Then
            Set objSender = Nothing
        End If
    On Error GoTo 0
    Exit Function

Err_FromAddress:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "FromAddress"
            Resume Exit_FromAddress
    End Select
    
End Function
Private Function InternetHeaders() As String
    ' Modified: 5/17/2003 By BB

    ' Capture the Internet headers from the current message
    '
    ' The Internet headers are only present in e-mails received from POP3 e-mails.
    ' They're not present in e-mails sent over Microsoft Exchange server.
    ' This function returns the Internet headers as a string value

    On Error GoTo Err_InternetHeaders
    
    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objCDO     As MAPI.Session
    Dim objMessage As MAPI.Message
    Dim objFields  As MAPI.Fields
    Dim strID      As String

    Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
    
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")
    'Find the current email item and get its EntryID
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    strID = objItem.EntryID
    'Then set up a CDO Session using a piggy-back login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    'Now get the item as a CDO Message
    Set objMessage = objCDO.GetMessage(strID)
    'Now get the headers from the message
    Set objFields = objMessage.Fields
    InternetHeaders = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
    'Now that the headers are captured in a string you can do whatever you want with them
    objCDO.Logoff

Exit_InternetHeaders:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objCDO Is Nothing) Then
            Set objCDO = Nothing
        End If
        If Not (objMessage Is Nothing) Then
            Set objMessage = Nothing
        End If
        If Not (objFields Is Nothing) Then
            Set objFields = Nothing
        End If
    On Error GoTo 0
    Exit Function

Err_InternetHeaders:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "InternetHeaders"
            Resume Exit_InternetHeaders
    End Select

End Function
Private Function GetMessageBody() As String
    
    ' Modified: 5/17/2003 By BB

    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objCDO     As MAPI.Session
    Dim objMessage As MAPI.Message
    Dim objFields  As MAPI.Fields
    Dim strID      As String
    
    On Error GoTo Err_GetMessageBody
    
    ' Instantiate an Outlook Application object
    Set objOutlook = CreateObject("Outlook.Application")
    'Find the current email item and get its EntryID
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    strID = objItem.EntryID
    'Then set up a CDO Session using a piggyback login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    'Now get the item as a CDO Message
    Set objMessage = objCDO.GetMessage(strID)
    'Now get the headers from the message
    Set objFields = objMessage.Fields
    GetMessageBody = objFields.Item(CdoPR_BODY).Value
    'Now that the headers are captured in a string you can do whatever you want with them
    objCDO.Logoff

Exit_GetMessageBody:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objCDO Is Nothing) Then
            Set objCDO = Nothing
        End If
        If Not (objMessage Is Nothing) Then
            Set objMessage = Nothing
        End If
        If Not (objFields Is Nothing) Then
            Set objFields = Nothing
        End If
    On Error GoTo 0
    Exit Function

Err_GetMessageBody:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "GetMessageBody"
            Resume Exit_GetMessageBody
    End Select

End Function
Private Sub SendNewMessage(strToAddress As String, strMessageBody As String)
    
    ' Modified: 5/17/2003 By BB

    On Error GoTo Err_SendNewMessage
    
    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objCDO     As MAPI.Session
    
    ' Instantiate an Outlook Application object
    Set objOutlook = CreateObject("Outlook.Application")
    'Then set up a CDO Session using a piggyback login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    ' create a new e-mail message
    Set objItem = objOutlook.CreateItem(olMailItem)
    objItem.Body = strMessageBody
    objItem.To = strToAddress
    objItem.Subject = "Fraudulent E-Mail Report"
    objItem.Send
    ' Now that the message has been sent, we can finish the session
    objCDO.Logoff

Exit_SendNewMessage:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objCDO Is Nothing) Then
            Set objCDO = Nothing
        End If
    On Error GoTo 0
    Exit Sub

Err_SendNewMessage:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "SendNewMessage"
            Resume Exit_SendNewMessage
    End Select
    
End Sub
Private Function ShowSenderHeaders() As String
    ' Modified: 5/17/2003 By BB

    ' Capture the REAL sender from the Internet headers in the current message
    '
    ' The Internet headers are only present in e-mails received from POP3 e-mails.
    ' They're not present in e-mails sent over Microsoft Exchange server.
    ' This function returns the senders as a string value

    On Error GoTo Err_ShowSenderHeaders
    
    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objCDO     As MAPI.Session
    Dim objMessage As MAPI.Message
    Dim objFields  As MAPI.Fields
    Dim strID      As String
    Dim strHeader  As String
    Dim strAdd     As String
    Dim lBegPos    As Long
    Dim lEndPos    As Long
    Dim lParen     As Long
    Dim strArr()   As String
    Dim strNew     As String
    
    Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
    
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")
    'Find the current email item and get its EntryID
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    strID = objItem.EntryID
    'Then set up a CDO Session using a piggy-back login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    'Now get the item as a CDO Message
    Set objMessage = objCDO.GetMessage(strID)
    'Now get the headers from the message
    Set objFields = objMessage.Fields
    strHeader = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
    strArr = Split(strHeader, vbCrLf)
    For lBegPos = LBound(strArr) To UBound(strArr)
        If Left(strArr(lBegPos), 14) = "Received: from" Then
            lEndPos = InStr(strArr(lBegPos), "from")
            strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 4))
            lParen = InStr(strNew, "(")
                If strAdd = "" Then
                    strAdd = Left$(strNew, lParen - 2)
                ElseIf strAdd = Left$(strNew, lParen - 2) Then
                    ' if it's the same don't add it again
                Else
                    strAdd = strAdd & ";" & Left$(strNew, lParen - 2)
                End If
        ElseIf Left(strArr(lBegPos), 12) = "Received: by" Then
            lEndPos = InStr(strArr(lBegPos), "by")
            strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 2))
            lParen = InStr(strNew, "(")
                If strAdd = "" Then
                    strAdd = Left$(strNew, lParen - 2)
                ElseIf strAdd = Left$(strNew, lParen - 2) Then
                    ' if it's the same don't add it again
                Else
                    strAdd = strAdd & ";" & Left$(strNew, lParen - 2)
                End If
        End If
    Next
    ShowSenderHeaders = strAdd
    'Now that the headers are captured in a string you can do whatever you want with them
    objCDO.Logoff

Exit_ShowSenderHeaders:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objCDO Is Nothing) Then
            Set objCDO = Nothing
        End If
        If Not (objMessage Is Nothing) Then
            Set objMessage = Nothing
        End If
        If Not (objFields Is Nothing) Then
            Set objFields = Nothing
        End If
    On Error GoTo 0
    Exit Function

Err_ShowSenderHeaders:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "ShowSenderHeaders"
            Resume Exit_ShowSenderHeaders
    End Select

End Function
Private Function CreateAbuseAddress() As String
    ' Modified: 5/17/2003 By BB

    ' Capture the REAL sender from the Internet headers in the current message
    ' and create an address like "abuse@hotmail.com" from it
    '
    ' The Internet headers are only present in e-mails received from POP3 e-mails.
    ' They're not present in e-mails sent over Microsoft Exchange server.
    ' This function returns the senders as a string value

    On Error GoTo Err_CreateAbuseAddress
    
    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objCDO     As MAPI.Session
    Dim objMessage As MAPI.Message
    Dim objFields  As MAPI.Fields
    Dim strID      As String
    Dim strHeader  As String
    Dim strAdd     As String
    Dim lBegPos    As Long
    Dim lEndPos    As Long
    Dim lParen     As Long
    Dim strArr()   As String
    Dim strNew     As String
    
    Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
    
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")
    'Find the current email item and get its EntryID
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    strID = objItem.EntryID
    'Then set up a CDO Session using a piggy-back login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    'Now get the item as a CDO Message
    Set objMessage = objCDO.GetMessage(strID)
    'Now get the headers from the message
    Set objFields = objMessage.Fields
    strHeader = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
    strArr = Split(strHeader, vbCrLf)
    For lBegPos = LBound(strArr) To UBound(strArr)
        If Left(strArr(lBegPos), 14) = "Received: from" Then
            lEndPos = InStr(strArr(lBegPos), "from")
            strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 4))
            lParen = InStr(strNew, "(")
                If strAdd = "" Then
                    strAdd = "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                    strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                ElseIf strAdd = Left$(strNew, lParen - 2) Then
                    ' if it's the same don't add it again
                Else
                    strAdd = strAdd & ";" & "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                    strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                End If
        ElseIf Left(strArr(lBegPos), 12) = "Received: by" Then
            lEndPos = InStr(strArr(lBegPos), "by")
            strNew = Right$(strArr(lBegPos), Len(strArr(lBegPos)) - (lEndPos + 2))
            lParen = InStr(strNew, "(")
                If strAdd = "" Then
                    strAdd = "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                    strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                ElseIf strAdd = Left$(strNew, lParen - 2) Then
                    ' if it's the same don't add it again
                Else
                    strAdd = strAdd & ";" & "abuse@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                    strAdd = strAdd & "; administrator@" & CleanDomainName(Trim$(Left$(strNew, lParen - 2)))
                End If
        End If
    Next
    CreateAbuseAddress = strAdd
    'Now that the headers are captured in a string you can do whatever you want with them
    objCDO.Logoff

Exit_CreateAbuseAddress:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objCDO Is Nothing) Then
            Set objCDO = Nothing
        End If
        If Not (objMessage Is Nothing) Then
            Set objMessage = Nothing
        End If
        If Not (objFields Is Nothing) Then
            Set objFields = Nothing
        End If
    On Error GoTo 0
    Exit Function

Err_CreateAbuseAddress:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "CreateAbuseAddress"
            Resume Exit_CreateAbuseAddress
    End Select

End Function
Private Function CleanDomainName(strAddressString As String) As String
    
    'Modified: 5/17/2003 By BB
    '
    ' remove multiple periods (".") from a domain name
    ' all we want are the last 2 sections (ie, from "mail.server.whatever.com" we want "whatever" and "com")
    
    Dim strArray() As String
    Dim strDomn    As String
    Dim L          As Long
    
    On Error GoTo Err_CleanDomainName
    
    If InStr(strAddressString, ".") = 0 Then
        strDomn = strAddressString & ".com"
    Else
        strArray = Split(strAddressString, ".")
        L = UBound(strArray)
        strDomn = strDomn & strArray(L - 1) & "." & strArray(L)
    End If
    CleanDomainName = strDomn

Exit_CleanDomainName:

    On Error GoTo 0
    Exit Function

Err_CleanDomainName:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "CleanDomainName"
            Resume Exit_CleanDomainName
    End Select

End Function
Private Sub DeleteMessage()
    
    ' Modified: 5/17/2003 By BB

    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    Dim objCDO     As MAPI.Session
    Dim objMessage As MAPI.Message
    Dim strID      As String
    
    On Error GoTo Err_DeleteMessage
    
    ' Instantiate an Outlook Application object
    Set objOutlook = CreateObject("Outlook.Application")
    'Find the current email item and get its EntryID
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    strID = objItem.EntryID
    'Then set up a CDO Session using a piggyback login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    'Now get the item as a CDO Message
    Set objMessage = objCDO.GetMessage(strID)
    objMessage.Delete
    ' message is deleted, quit session
    objCDO.Logoff

Exit_DeleteMessage:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
        If Not (objCDO Is Nothing) Then
            Set objCDO = Nothing
        End If
        If Not (objMessage Is Nothing) Then
            Set objMessage = Nothing
        End If
    On Error GoTo 0
    Exit Sub

Err_DeleteMessage:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "DeleteMessage"
            Resume Exit_DeleteMessage
    End Select

End Sub
Private Sub CloseMessage()
    
    ' Modified: 5/17/2003 By BB

    Dim objOutlook As Outlook.Application
    Dim objItem    As Outlook.MailItem
    
    On Error GoTo Err_CloseMessage
    
    ' Instantiate an Outlook Application object
    Set objOutlook = CreateObject("Outlook.Application")
    'Find the current e-mail item
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    objItem.Close olDiscard

Exit_CloseMessage:

    On Error Resume Next
        If Not (objOutlook Is Nothing) Then
            Set objOutlook = Nothing
        End If
        If Not (objItem Is Nothing) Then
            Set objItem = Nothing
        End If
    On Error GoTo 0
    Exit Sub

Err_CloseMessage:

    Select Case Err
        Case 0
            Resume Next
        Case Else
            MsgBox "The following occurred:" & vbCrLf & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.Description, vbInformation, "basOpenLatestMessage" & ": " & "CloseMessage"
            Resume Exit_CloseMessage
    End Select

End Sub

hth~
B~

Boni J. Rychener
Hammerman Associates, Inc.
Crystal Training and Crystal Material
On-site and public classes
Low-cost telephone/email support
FREE independent Crystal newsletter

http://www.hammerman.com

800-783-2269

 

[Spab23]

Thanks for that code listing, Boni, but it looks way too complicated for what I need. (And way over my level of understanding of VB!)

I just need to script a series of keyboard commands like a macro. I didn't think it would be this difficult!