VbaFin.com

Visual Basic for Financial Professionals
Home      Outlook
Below are 2 email examples – one to send and one to just display your message (to allow for editing before sending). Please note that HTMLBody property is being used to allow you to include HTML tags with your text. We’ve also added an example that allows you to pick up names from your Outlook Address Book.
 
To be able to use the macros you need to download and register Outlook Redemption. The developer version is free. With Outlook Redemption you can make your code run unaffected by the Outlook Security Patch, display Address Book and much, much more ...
 
Sub SendMail(mlMsg, mlRecepients, mlSubject, Optional mlCC,Optional mlAttachments)
 
    'If you are using Option Explicit you will have to declare all variables below since I didn't ...
    Set myItem = CreateObject("Redemption.SafeMailItem")
    Set olkApp = New Outlook.Application
    Set tmpItem = olkApp.CreateItem(0)
 
    myItem.Item = tmpItem
    If Not IsArray(mlRecepients) Then
        If mlRecepients = "Self" Then
            Set CU = CreateObject("Redemption.SafeCurrentUser")
            mlRecepients = CU.Name
            CU.Cleanup 'do call cleanup, otherwise Outlook might have trouble properly closing down
            Set CU = Nothing
        End If
        myItem.Recipients.Add mlRecepients
    Else
        For i = 1 To UBound(mlRecepients)
            myItem.Recipients.Add mlRecepients(i)
        Next i
    End If
 
    If Not IsMissing(mlCC) Then
        If Not IsArray(mlCC) Then
            Set tmp = myItem.Recipients.Add(mlCC)
            tmp.Type = 2
        Else
            For i = 1 To UBound(mlCC)
                Set tmp = myItem.Recipients.Add(mlCC(i))
                 tmp.Type = 2
            Next i
        End If
    End If
 
    If Not IsMissing(mlAttachments) Then
        If Not IsArray(mlAttachments) Then
            myItem.Attachments.Add mlAttachments
        Else
            For i = 1 To UBound(mlRecepients)
                myItem.Attachments.Add mlAttachments(i)
            Next i
        End If
    End If
 
    myItem.HTMLBody = mlMsg
    myItem.Subject = mlSubject
    On Error Resume Next
    myItem.Recipients.ResolveAll
    myItem.Send
 
    If Err.Number <> 0 Then
        msgPrompt = "Email could not be sent. Probably wrong recipient or insufficient space ..."
        msgPrompt = msgPrompt & Chr(13) & "The message will be diplayed instead."
        MsgTitle = "Send Email"
        MsgBox msgPrompt, vbExclamation + vbOKOnly, MsgTitle
        myItem.Display
    End If
 
    Set myItem = Nothing
    Set olkApp = Nothing
    Set tmpItem =Nothing
   
End Sub
 
Sub DisplayMail(mlMsg, mlRecepients, mlSubject, Optional mlCC, Optional mlAttachments)
 
    Dim olkApp As Outlook.Application
    Dim tmpItem As Outlook.MailItem
    'If you are using Option Explicit you will have to declare all variables below since I didn't ...
 
    Set myItem = CreateObject("Redemption.SafeMailItem")
    Set olkApp = NewOutlook.Application
    Set tmpItem = olkApp.CreateItem(0)
 
    myItem.Item = tmpItem
    If Not IsArray(mlRecepients) Then
        If mlRecepients = "Self" Then
            Set CU = CreateObject("Redemption.SafeCurrentUser")
            mlRecepients = CU.Name
            CU.Cleanup 'do call cleanup, otherwise Outlook might have trouble properly closing down
            Set CU = Nothing
        End If
        myItem.Recipients.Add mlRecepients
    Else
        For i = 1 To UBound(mlRecepients)
            myItem.Recipients.Add mlRecepients(i)
        Next i
    End If

    If Not IsMissing(mlCC) Then
        If Not IsArray(mlCC) Then
            Set tmp = myItem.Recipients.Add(mlCC)
            tmp.Type = 2
        Else
            For i = 1 To UBound(mlCC)
                Set tmp = myItem.Recipients.Add(mlCC(i))
                tmp.Type = 2
            Next i
        End If
    End If

    If Not IsMissing(mlAttachments) Then
        If Not IsArray(mlAttachments) Then
            myItem.Attachments.Add mlAttachments
        Else
            For i = 1 To UBound(mlRecepients)
                myItem.Attachments.Add mlAttachments(i)
            Next i
        End If
    End If
 
    myItem.HTMLBody = mlMsg
    myItem.Subject = mlSubject
    On Error Resume Next
    myItem.Recipients.ResolveAll
    myItem.Display
 
    Set myItem = Nothing
    Set olkApp = Nothing
    Set tmpItem =Nothing
   
End Sub
 
In addition Outlook events provide the opportunity to process incoming mail (Application_NewMail) or use it as a trigger (Application_Reminder) for running processes at different times. Below are 2 simple examples how to do that.
 
Assuming you are receiving a file that is called “Distributions Summary.xls” and whoever’s sending it is using Subject lines "DISTRIBUTION PAYOUT", "DISTRIBUTION RATES" or "DISTRIBUTION SUMMARY" and you want to save it as “myFolder\myFiles\LastFile.xls”. The macro is also using the SendMail subroutine displayed above:
 
Private Sub Application_NewMail()
     SaveFundsData
End Sub
 
Sub SaveFundData()
 
    Const FileFolder = "myFolder\myFiles\"
    Const FileName = "LastFile.xls"
 
    With  Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items.Item(1)
        If.Attachments.Count = 0 Then Exit Sub
        If InStr(UCase(.Subject), "DISTRIBUTION PAYOUT") = 0 Then
            If InStr(UCase(.Subject), "DISTRIBUTION RATES") = 0 Then
                IfInStr(UCase(.Subject), "DISTRIBUTION SUMMARY") = 0 Then Exit Sub
            End If
        End If
        For i = 1 To .Attachments.Count
            If InStr(UCase(.Attachments.Item(i)), ".XLS") Then
                If InStr(UCase(.Attachments.Item(i)), UCase("Distribution Summary"))Then
                    On Error Resume Next
         .          Attachments.Item(i).SaveAsFile FileFolder & FileName
                    If Err.Number = 0 Then
                        SendMail "", "Self", "Fund Data Saved Successfully"
                    Else
                        ErrDescription = Err.Description
                        Err.Clear
                        SendMail "", "Self", "Error while saving Fund Data: " & ErrDescription
                    End If
                End If
            End If
        Next i
    End With
 
End Sub
 
As mentioned above you can set up a reminder (let’s call it OverNightProcesses) and then use it to trigger a macro:

Private Sub Application_Reminder(ByVal Item As Object)
    If Item = "Overnight" Then  OvernightProcesses
End Sub
 
Sub OvernightProcesses()
    ‘//Add code here
End Sub
 
And finally here’s the example that allows you to pick names from your outlook Address book:
 
Sub GetNames()
 
    Dim AB As RDOAddressBook
    Set RDOSession = CreateObject("Redemption.RDOSession")
    RDOSession.Logon
    Set AB = RDOSession.AddressBook
    On Error Resume Next
    Set Recips = AB.ShowAddressBook(RecipLists:=1, Title:="Select Names", ToLabel:="Add")
 
End Sub