Send Attachment via Outlook Email (1 Viewer)

Function StartOutlook(strTo As String, Optional AttachmentPath As Variant)
    On Error GoTo Error_Handler
    Dim oOutlook        As Object
    Dim sAPPPath        As String

    If IsAppRunning("Outlook.Application") = True Then    'Outlook was already running
        Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    Else    'Could not get instance of Outlook, so create a new one
        sAPPPath = GetAppExePath("outlook.exe")    'determine outlook's installation path
        Shell (sAPPPath)    'start outlook
        Do While Not IsAppRunning("Outlook.Application")
            DoEvents
        Loop
        Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    End If

    Const olMailItem = 0
    Dim oOutlookMsg     As Object
    Dim oOutlookRecip As Object
    Dim oOutlookAttach As Object
    Set oOutlookMsg = oOutlook.CreateItem(olMailItem)    'Start a new e-mail message
 
    With oOutlookMsg
      Set oOutlookRecip = .Recipients.Add(strTo)
      Set oOutlookAttach = .Attachments.Add(AttachmentPath)
      .Importance = 2  'Importance Level  0=Low,1=Normal,2=High
    End With
 
    oOutlookMsg.Display    'Show the message to the user
 
Error_Handler_Exit:
    On Error Resume Next
    Set oOutlook = Nothing
    Exit Function
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: StartOutlook" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit

End Function
 
 
 
Function IsAppRunning(sApp As String) As Boolean
    On Error GoTo Error_Handler
    Dim oApp            As Object
 
    Set oApp = GetObject(, sApp)
    IsAppRunning = True
 
Error_Handler_Exit:
    On Error Resume Next
    Set oApp = Nothing
    Exit Function
 
Error_Handler:
    Resume Error_Handler_Exit
End Function
 
 
 
Function GetAppExePath(ByVal sExeName As String) As String
    On Error GoTo Error_Handler
    Dim WSHShell        As Object
 
    Set WSHShell = CreateObject("Wscript.Shell")
    GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
 
Error_Handler_Exit:
    On Error Resume Next
    Set WSHShell = Nothing
    Exit Function
 
Error_Handler:
    If Err.Number = -2147024894 Then
        'Cannot locate requested exe????
    Else
        MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: GetAppExePath" & vbCrLf & _
               "Error Description: " & Err.Description, _
               vbCritical, "An Error has Occured!"
    End If
    Resume Error_Handler_Exit
End Function

    ' See if Outlook is open, otherwise open it
    'If fIsOutlookRunning = False Then
        Set objOutlook = CreateObject("Outlook.Application")
        'Call OpenOutlook
        'Pause (5)
   ' Else
        'Set objOutlook = GetObject(, "Outlook.Application")
    'End If

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment