Create an Outlook-mailitem OR just attach a file ??

[ksor]

As a part of an Access DB I have a button on several forms where the user can click to send a file handled in each of these forms.

I used this code and it work nicely - this code is used an ALL forms when the mail.button is present:

Public Sub sendMail(Attach As String, txt As String)
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    If Attach <> "" Or txt <> "" Then
        Set appOutLook = CreateObject("Outlook.Application")
        Set MailOutLook = appOutLook.CreateItem(olMailItem)
        With MailOutLook
            .BodyFormat = olFormatHTML         ' olFormatRichText
            .To = ""
            .cc = ""
            '.bcc = ""
            .Subject = "Dokument fra Keld Sørensen"
            If txt <> "" Then
                .Body = txt          ' ellers laver den ikke linieskifte med crLf(1) !!!!!!!!!!
               ' .HTMLBody = txt
            Else
               .HTMLBody = "Indtast en besked her !"
            End If
            If Attach <> "" Then .Attachments.add (Attach)
            ' .Send     ' if you want to send without editing
            .Display    ' showing the mail for editing BEFORE you send it manually
        End With
    Else
        MsgBox "Du vil ikke skrive tekst, du vil ikke vedhæfte noget !!" & CrLf(2) & _
               "Hvad vil du egentlig ... Ret fejlen og prøv igen !"
    End If
End Sub

But often several files has to be send to the same person from several different forms in my DB - each with that "Mail"-button to click.

How can I change the code to just attaching the files IF the mailitem is already created ?

[ksor]

Ifound out myself ... here it is:

Public Sub sendMail(Attach As String, txt As String)
    ' Her bruges OUTLOOK
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    If Attach <> "" Or txt <> "" Then
        On Error GoTo NoOutL
        Set MailOutLook = GetCurrentItem    ' appOutLook.GetItem(olMailItem)
NoOutL: On Error GoTo 0
        If MailOutLook Is Nothing Then
            Set appOutLook = CreateObject("Outlook.Application")
            Set MailOutLook = appOutLook.CreateItem(olMailItem)
        End If
        With MailOutLook
            .BodyFormat = olFormatHTML         ' olFormatRichText
            .To = ""
            .cc = ""
            '.bcc = ""
            .Subject = "Dokument fra Keld Sørensen"
            If txt <> "" Then
                .Body = .Body & CrLf(2) & txt           ' ellers laver den ikke linieskifte med crLf(1) !!!!!!!!!!
               ' .HTMLBody = txt
            Else
               .HTMLBody = "Indtast en besked her !"
            End If
            If Attach <> "" Then .Attachments.add (Attach)
            ' .Send     ' Her sendes mailen umiddelbart
            .Display    ' Her vises mailen og du skal selv sende den
        End With
    Else
        MsgBox "Du vil ikke skrive tekst, du vil ikke vedhæfte noget !!" & CrLf(2) & _
               "Hvad vil du egentlig ... Ret fejlen og prøv igen !"
    End If
End Sub

Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
    Set objApp = CreateObject("Outlook.Application")
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
        Case Else
            ' anything else will result in an error, which is
            ' why we have the error handler above
    End Select
    Set objApp = Nothing
End Function