How to open outlook using VBA?

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
            objOutlookRecip.Resolve
        Next
       
        ' Should we display the message before sending?
        If bDisplayMsg Then
            .Display
        Else
            .Save
            .sEnd
        End If
    End With
    Set objOutlook = Nothing
End Sub

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

eg

    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?

Thanks

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 " & _
                         "Subsystem\Profiles"
   
           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
        .Send
    End With

    Set objCDOMail = Nothing

    objSession.Logoff
    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, _
                hKey)
   
    lRetVal = QueryValueEx(hKey, _
                sValueName, _
                vValue)
    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)
          Else
             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
   
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function