We help IT Professionals succeed at work.

We've partnered with Certified Experts, Carl Webster and Richard Faulkner, to bring you a podcast all about Citrix Workspace, moving to the cloud, and analytics & intelligence. Episode 2 coming soon!Listen Now


How to open outlook using VBA?

indyng asked
Medium Priority
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.

Watch Question

Top Expert 2006

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
Top Expert 2006

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.


How do I use CDO?

Top Expert 2006
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 = "Test@test.com"

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

    'Name of attachment
    If strAttach <> "" Then objEmail.AddAttachment strAttach
    objEmail.configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    '**** test.com - here u enter your smtp server name, whatever that is
    objEmail.configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.xxx.com"
    objEmail.configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    objEmail.configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/sendUserName") = "myuserid"
    objEmail.configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/senduserPassword") = "mypassword"
    objEmail.configuration.Fields.item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 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

Not the solution you were looking for? Getting a personalized solution is easy.

Ask the Experts
Top Expert 2006

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.

    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 = "indy@ee.com"
        .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

Access more of Experts Exchange with a free account
Thanks for using Experts Exchange.

Create a free account to continue.

Limited access with a free account allows you to:

  • View three pieces of content (articles, solutions, posts, and videos)
  • Ask the experts questions (counted toward content limit)
  • Customize your dashboard and profile

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.


Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.