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