How to open outlook using VBA?

Posted on 2009-02-18
Last Modified: 2012-05-06
Hi Experts,

What is the VBA to do the following?
Check if Outlook is open. If not open, then open Outlook. If Outlook prompts for Profile Name then select one programmatically. After email is sent, close Outlook using VBA.

Question by:indyng
    LVL 65

    Expert Comment

    How about something like this. It is using late binding to access Outlook

    Pass in message flag (true to show, false to automatically send), subject, message body, email recipient, and optional cc and bcc emails).

    Sub SendMessageOA(ByVal bDisplayMsg As Boolean, _
                      ByVal sSubject As String, _
                      ByVal sMsgBody As String, _
                      ByVal sEmailTo As String, _
                      Optional ByVal sCCTo As String = "", _
                      Optional ByVal sBCCTo As String = "")
        Dim objOutlook As Object
        Dim objOutlookMsg As Object
        Dim objOutlookRecip As Object
        Dim objOutlookAttach As Object
        ' Create the Outlook session.
        Set objOutlook = CreateObject("Outlook.Application")
        ' Create the message.
        Set objOutlookMsg = objOutlook.CreateItem(0)
        With objOutlookMsg
            'Add the To recipient(s) to the message.
            Set objOutlookRecip = .Recipients.Add(sEmailTo)
            objOutlookRecip.Type = olTo
            'Add the CC recipient(s) to the message.
            If sCCTo <> "" Then
                Set objOutlookRecip = .Recipients.Add(sCCTo)
                objOutlookRecip.Type = olCC
            End If
            'Add the BCC recipient(s) to the message.
            If sBCCTo <> "" Then
                Set objOutlookRecip = .Recipients.Add(sBCCTo)
                objOutlookRecip.Type = olBCC
            End If
            'Set the Subject, Body, and Importance of the message.
            .Subject = sSubject
            .Body = sMsgBody
            'Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
            ' Should we display the message before sending?
            If bDisplayMsg Then
            End If
        End With
        Set objOutlook = Nothing
    End Sub
    LVL 65

    Expert Comment

    oh, to chck existing outlook, we should get the object first


        Set objOutlook = GetObject("", "Outlook.Application")
        If objOutlook = Null Then
            Set objOutlook = CreateObject("Outlook.Application")
        End If

    Now do remember, you may get prompted for a control. In this case, you could use CDO, this will not prompt.

    LVL 1

    Author Comment

    How do I use CDO?

    LVL 65

    Accepted Solution

    CDO example

    Public Function SendEmailCDO2(ByVal strTo As String, _
                                  ByVal strMessage As String, _
                                  ByVal strSubject As String, _
                                  Optional ByVal strAttach As String)
        Dim objEmail As Object
        On Error Resume Next
        Set objEmail = CreateObject("CDO.Message")

        '**** email address of sender
        objEmail.From = ""

        objEmail.To = strTo
        objEmail.Subject = strSubject
        objEmail.Textbody = strMessage

        'Name of attachment
        If strAttach <> "" Then objEmail.AddAttachment strAttach
        objEmail.configuration.Fields.item("") = 2
        '**** - here u enter your smtp server name, whatever that is
        objEmail.configuration.Fields.item("") = ""
        objEmail.configuration.Fields.item("") = 25
        objEmail.configuration.Fields.item("") = "myuserid"
        objEmail.configuration.Fields.item("") = "mypassword"
        objEmail.configuration.Fields.item("") = 1
        If Err.Number <> 0 Then
            MsgBox "Error in sending. " & Err.Description
            MsgBox "Sent"   'remove this if u dont want confirmation
        End If
        Set objEmail = Nothing

    End Function
    LVL 65

    Expert Comment

    This is a better example. It still uses CDO but makes use of profiles. Advantage with this is you dont have to bother with smtp info like above.

    Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128
    End Type

    Private Declare Function GetVersionEx Lib "kernel32" _
       Alias "GetVersionExA" _
             (ByRef lpVersionInformation As OSVERSIONINFO) As Long

    Private Declare Function RegCloseKey Lib "advapi32.dll" _
             (ByVal hKey As Long) As Long

    Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
       Alias "RegOpenKeyExA" _
             (ByVal hKey As Long, _
             ByVal lpSubKey As String, _
             ByVal ulOptions As Long, _
             ByVal samDesired As Long, _
             phkResult As Long) As Long

    Private Declare Function RegQueryValueExString Lib "advapi32.dll" _
       Alias "RegQueryValueExA" _
             (ByVal hKey As Long, _
             ByVal lpValueName As String, _
             ByVal lpReserved As Long, _
             lpType As Long, _
             ByVal lpData As String, _
             lpcbData As Long) As Long

    Private Declare Function RegQueryValueExLong Lib "advapi32.dll" _
       Alias "RegQueryValueExA" _
             (ByVal hKey As Long, _
             ByVal lpValueName As String, _
             ByVal lpReserved As Long, _
             lpType As Long, lpData As Long, _
             lpcbData As Long) As Long

    Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
       Alias "RegQueryValueExA" _
             (ByVal hKey As Long, _
             ByVal lpValueName As String, _
             ByVal lpReserved As Long, _
             lpType As Long, _
             ByVal lpData As Long, _
             lpcbData As Long) As Long
    Private Const REG_SZ As Long = 1
    Private Const REG_DWORD As Long = 4
    Private Const HKEY_CURRENT_USER = &H80000001
    Private Const KEY_ALL_ACCESS = &H3F

    Sub SendEmailCDO(ByVal sTo As String, ByVal sSubject As String, ByVal sMsgBody As String)

        Dim objSession As Object
        Dim objCDOMail As Object
        Dim osinfo As OSVERSIONINFO
        Dim retvalue
        Dim sKeyName As String
        Dim sValueName As String
        Dim sDefaultUserProfile As String

        'Create a session
        Set objSession = CreateObject("MAPI.Session")
        On Error Resume Next
        objSession.Logon NewSession:=False, ShowDialog:=False
        'Mapi login failed, get default profile
        If Err.Number = -2147221231 Then
            'get default profile
            osinfo.dwOSVersionInfoSize = 148
            osinfo.szCSDVersion = Space$(128)
            retvalue = GetVersionEx(osinfo)
            Select Case osinfo.dwPlatformId
               Case 0   'Unidentified
                  MsgBox "Unidentified Operating System.  " & _
                     "Cannot log on to messaging."
                  Exit Sub
               Case 1   'Win95
                  sKeyName = "Software\Microsoft\" & _
                             "Windows Messaging " & _
               Case 2   'NT
                   sKeyName = "Software\Microsoft\Windows NT\" & _
                              "CurrentVersion\" & _
                              "Windows Messaging Subsystem\Profiles"
            End Select
            sValueName = "DefaultProfile"
            sDefaultUserProfile = QueryValue(sKeyName, sValueName)
            objSession.Logon ProfileName:=sDefaultUserProfile
        ElseIf Err.Number > 0 Then
            MsgBox "Failed to login"
            Exit Sub
        End If
        On Error GoTo 0
        Set objCDOMail = CreateObject("CDO.Message")

        With objCDOMail
            .To = sTo
            .FROM = ""
            .Subject = sSubject
            .TextBody = sMsgBody
        End With

        Set objCDOMail = Nothing

        Set objSession = Nothing
    End Sub

    Private Function QueryValue(sKeyName As String, sValueName As String)
        Dim lRetVal As Long     'Result of the API functions.
        Dim hKey As Long        'Handle of the opened key.
        Dim vValue As Variant   'Setting of the queried value.
        lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, _
                    sKeyName, _
                    0, _
                    KEY_ALL_ACCESS, _
        lRetVal = QueryValueEx(hKey, _
                    sValueName, _
        QueryValue = vValue
        RegCloseKey (hKey)
    End Function

    Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
        Dim cch As Long
        Dim lrc As Long
        Dim lType As Long
        Dim lValue As Long
        Dim sValue As String
        On Error GoTo QueryValueExError
        ' Determine the size and the type of the data to be read.
        lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
        If lrc <> 0 Then Error 5
        Select Case lType
           ' For strings
           Case REG_SZ:
              sValue = String(cch, 0)
              lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
                 sValue, cch)
              If lrc = 0 Then
                 vValue = Left$(sValue, cch)
                 vValue = Empty
              End If
           ' For DWORDS
           Case REG_DWORD:
              lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
                 lValue, cch)
              If lrc = 0 Then vValue = lValue
           Case Else
              'All other data types that are not supported.
              lrc = -1
        End Select
        QueryValueEx = lrc
        Exit Function
        Resume QueryValueExExit
    End Function


    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    IT, Stop Being Called Into Every Meeting

    Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

    In the previous article, Using a Critera Form to Filter Records (, the form was basically a data container storing user input, which queries and other database objects could read. The form had to remain op…
    A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
    In Microsoft Access, learn how to use Dlookup and other domain aggregate functions and one method of specifying a string value within a string. Specify the first argument, which is the expression to be returned: Specify the second argument, which …
    Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

    737 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    16 Experts available now in Live!

    Get 1:1 Help Now