Opening Outlook and attaching a specific file

[mel_flynn]

How can I open outlook/or the default mail service to a new outgoing mail that has a specified file attached?

[mcsd02]

Here's some code I wrote for an emailer class that uses Outlook. It allows to, cc, bcc, subject, body and one attachment (multiple attachments could be sent by passing an array instead of just a string).

Option Explicit
 
Public Event ErrorMessage(ErrorNumber As Integer, ErrorMessage As String, Source As String)
 
Private objOutlook As New Outlook.Application
Private objOutlookMail As Outlook.MailItem
Private objOutlookRecip As Outlook.Recipient
 
Public Function Send(RecipientAddress As String, Optional CC As String, Optional BCC As String, Optional Subject As String, Optional MsgBody As String, Optional Attachment As String) As Boolean
On Error GoTo ComposeErr
    
    Dim RecipientKnown As Boolean
    Dim FinalToAddress As String
    Dim FinalCCAddress As String
    Dim FinalBCCAddress As String
    Dim Recips() As String
    Dim i As Integer
    Dim Dirs() As String
    
    With objOutlookMail
        
        Recips = Split(Trim(RecipientAddress), ";")
        For i = 0 To UBound(Recips)
            .Recipients.Add Recips(i)
            .Recipients.Item(Recips(i)).Type = olTo
            RecipientKnown = .Recipients.Item(Recips(i)).Resolve
            If RecipientKnown Then
                If UBound(Recips) > 0 Then
                    FinalToAddress = FinalToAddress & ";" & Recips(i)
                Else
                    FinalToAddress = Recips(i)
                End If
            End If
        Next i
        
        If Trim(CC) <> "" Then
            ReDim Recips(0)
            Recips = Split(Trim(CC), ";")
            For i = 0 To UBound(Recips)
                .Recipients.Add Recips(i)
                .Recipients.Item(Recips(i)).Type = olCC
                RecipientKnown = .Recipients.Item(Recips(i)).Resolve
                If RecipientKnown Then
                    If UBound(Recips) > 0 Then
                        FinalCCAddress = FinalCCAddress & ";" & Recips(i)
                    Else
                        FinalCCAddress = Recips(i)
                    End If
                End If
            Next i
        End If
 
        If Trim(BCC) <> "" Then
            ReDim Recips(0)
            Recips = Split(Trim(BCC), ";")
            For i = 0 To UBound(Recips)
                .Recipients.Add Recips(i)
                .Recipients.Item(Recips(i)).Type = olBCC
                RecipientKnown = .Recipients.Item(Recips(i)).Resolve
                If RecipientKnown Then
                    If UBound(Recips) > 0 Then
                        FinalBCCAddress = FinalBCCAddress & ";" & Recips(i)
                    Else
                        FinalBCCAddress = Recips(i)
                    End If
                End If
            Next i
        End If
        
        If Left$(Trim(FinalToAddress), 1) = ";" Then FinalToAddress = Mid$(Trim(FinalToAddress), 2)
        If Left$(Trim(FinalCCAddress), 1) = ";" Then FinalCCAddress = Mid$(Trim(FinalCCAddress), 2)
        If Left$(Trim(FinalBCCAddress), 1) = ";" Then FinalBCCAddress = Mid$(Trim(FinalBCCAddress), 2)
        
        If Trim(FinalToAddress) <> "" Then
            .To = Trim(FinalToAddress)
            .CC = Trim(FinalCCAddress)
            .BCC = Trim(FinalBCCAddress)
            .Importance = olImportanceHigh
            .Subject = Trim(Subject)
            .Body = MsgBody
            If Trim(Attachment) <> "" Then
                Dirs = Split(Attachment, "\")
                .Attachments.Add Attachment, olByValue, 1, Dirs(UBound(Dirs))
            End If
            .Send
        Else
            Send = False
            RaiseEvent ErrorMessage(1001, "No known recipient addresses found.", "Email:Send")
            Exit Function
        End If
    End With
    
    Send = True
    
    Exit Function
 
ComposeErr:
    
    Send = False
    RaiseEvent ErrorMessage(Err.Number, Err.Description, "Email:Send")
 
End Function
 
Private Sub Class_Initialize()
 
    Set objOutlookMail = objOutlook.CreateItem(olMailItem)
    
End Sub

Hope this helps.

[mel_flynn]

Hi mcsd02,
Thanks for the reply. I found this myself and it suits my needs better .

    If (fso.FileExists(rsQuoteHdr!FileLocation)) Then
        Dim olapp As New Outlook.Application
        Dim olMail As Outlook.MailItem
        Dim myAttachment As Outlook.Attachments

        'Create a new mail object form the
        'Outlook98 Application object
        Set olMail = olapp.CreateItem(olMailItem)
        Set myAttachment = olMail.Attachments
        myAttachment.Add "" & rsQuoteHdr!FileLocation
        olMail.Body = strMessage & vbNewLine & vbNewLine
        'Tell Outlook to send this message
        olMail.Display
    
        'Be kind to your environment and clean
        'up your unused objects
        Set olMail = Nothing
        Set olapp = Nothing
        
    Else
        msg = MsgBox("No file detected, please SaveAs first", vbOKOnly & vbInformation, "No file found")
        Call SaveAs_Click
    End If

Thanks anyway

[mcsd02]

Here's some code I wrote for an emailer class that uses Outlook. It allows to, cc, bcc, subject, body and one attachment (multiple attachments could be sent by passing an array instead of just a string).

Option Explicit
 
Public Event ErrorMessage(ErrorNumber As Integer, ErrorMessage As String, Source As String)
 
Private objOutlook As New Outlook.Application
Private objOutlookMail As Outlook.MailItem
Private objOutlookRecip As Outlook.Recipient
 
Public Function Send(RecipientAddress As String, Optional CC As String, Optional BCC As String, Optional Subject As String, Optional MsgBody As String, Optional Attachment As String) As Boolean
On Error GoTo ComposeErr
    
    Dim RecipientKnown As Boolean
    Dim FinalToAddress As String
    Dim FinalCCAddress As String
    Dim FinalBCCAddress As String
    Dim Recips() As String
    Dim i As Integer
    Dim Dirs() As String
    
    With objOutlookMail
        
        Recips = Split(Trim(RecipientAddress), ";")
        For i = 0 To UBound(Recips)
            .Recipients.Add Recips(i)
            .Recipients.Item(Recips(i)).Type = olTo
            RecipientKnown = .Recipients.Item(Recips(i)).Resolve
            If RecipientKnown Then
                If UBound(Recips) > 0 Then
                    FinalToAddress = FinalToAddress & ";" & Recips(i)
                Else
                    FinalToAddress = Recips(i)
                End If
            End If
        Next i
        
        If Trim(CC) <> "" Then
            ReDim Recips(0)
            Recips = Split(Trim(CC), ";")
            For i = 0 To UBound(Recips)
                .Recipients.Add Recips(i)
                .Recipients.Item(Recips(i)).Type = olCC
                RecipientKnown = .Recipients.Item(Recips(i)).Resolve
                If RecipientKnown Then
                    If UBound(Recips) > 0 Then
                        FinalCCAddress = FinalCCAddress & ";" & Recips(i)
                    Else
                        FinalCCAddress = Recips(i)
                    End If
                End If
            Next i
        End If
 
        If Trim(BCC) <> "" Then
            ReDim Recips(0)
            Recips = Split(Trim(BCC), ";")
            For i = 0 To UBound(Recips)
                .Recipients.Add Recips(i)
                .Recipients.Item(Recips(i)).Type = olBCC
                RecipientKnown = .Recipients.Item(Recips(i)).Resolve
                If RecipientKnown Then
                    If UBound(Recips) > 0 Then
                        FinalBCCAddress = FinalBCCAddress & ";" & Recips(i)
                    Else
                        FinalBCCAddress = Recips(i)
                    End If
                End If
            Next i
        End If
        
        If Left$(Trim(FinalToAddress), 1) = ";" Then FinalToAddress = Mid$(Trim(FinalToAddress), 2)
        If Left$(Trim(FinalCCAddress), 1) = ";" Then FinalCCAddress = Mid$(Trim(FinalCCAddress), 2)
        If Left$(Trim(FinalBCCAddress), 1) = ";" Then FinalBCCAddress = Mid$(Trim(FinalBCCAddress), 2)
        
        If Trim(FinalToAddress) <> "" Then
            .To = Trim(FinalToAddress)
            .CC = Trim(FinalCCAddress)
            .BCC = Trim(FinalBCCAddress)
            .Importance = olImportanceHigh
            .Subject = Trim(Subject)
            .Body = MsgBody
            If Trim(Attachment) <> "" Then
                Dirs = Split(Attachment, "\")
                .Attachments.Add Attachment, olByValue, 1, Dirs(UBound(Dirs))
            End If
            .Send
        Else
            Send = False
            RaiseEvent ErrorMessage(1001, "No known recipient addresses found.", "Email:Send")
            Exit Function
        End If
    End With
    
    Send = True
    
    Exit Function
 
ComposeErr:
    
    Send = False
    RaiseEvent ErrorMessage(Err.Number, Err.Description, "Email:Send")
 
End Function
 
Private Sub Class_Initialize()
 
    Set objOutlookMail = objOutlook.CreateItem(olMailItem)
    
End Sub

Hope this helps.