VBA Access - Outlook

[JohS]

Hi. Would appreciate some feedback telling me why the code doesn't hit its
Recipient?

(The Email ends up in draft (and sometimes even in the Inbox) and I guess it
has something to do with the lack of recipient). In advance thanks, JohS




Private Sub btnSendEmail_Click()
Dim objword As Word.Application
Dim sMal As String
Dim DB As Database
Dim rec As Recordset
Dim sSql As String
On Error Resume Next



DoCmd.Hourglass True
Set DB = CurrentDb()
'Henter inn alle opplysninger om kunden som ble valgt
sSql = "SELECT tblKunder * FROM tblKunder WHERE (((tblKunder.FirmaNavn)= " &
Forms!frmKunder.lstFirmaNavn & "))"
Set rec = DB.OpenRecordset(sSql)

If Not rec.BOF Then
'Lager referanse til Word
strWordMal = Application.CurrentProject.Path & "\invitasjon.dot"
On Error Resume Next
Set objword = GetObject(, "Word.application")
If objword Is Nothing Then Set objword = CreateObject("Word.application")
sMal = objword.Documents.Add(Template:=strWordMal)
'Åpner et dokument basert på valgt mal
objword.Documents.Add sMal
'Aktiverer, synligjør og maksimerer Word
objword.Application.Activate
objword.Application.Visible = True
'objword.Application.WindowState = wdWindowStatemaximize
'Fyller inn tekst ved bokmerkene

objword.ActiveDocument.Bookmarks("bookmarkFirmanavn").Select
If Not IsNull(rec!lstFirmaNavn) Then objword.Selection.Text =
Me!lstFirmaNavn

objword.ActiveDocument.Bookmarks("bookmarkKontaktEmail").Select
If Not IsNull(rec!lstKontaktEmail) Then objword.Selection.Text =
Me!lstKontaktEmail

'Lager referanse til Word
strWordSave = Application.CurrentProject.Path & "\invitasjon.doc"

objword.ActiveDocument.SaveAs (strWordSave)
objword.Application.Visible = False
objword.Quit
Set objword = Nothing


End If
DoCmd.Hourglass False
DoCmd.Close



Dim objOutlook As Outlook.Application
Dim objMessage As Outlook.MailItem
Dim objEmailReceivers As Outlook.Recipient
Dim objAttachment As Outlook.Attachment
Dim strError As String
strError = "Mangler info"
Set objAttachment = strWordSave

Set objOutlook = GetObject(, "Outlook.application")
If objOutlook Is Nothing Then Set objOutlook =
CreateObject("Outlook.application")
Set objMessage = objOutlook.CreateItem(olMailItem)

With objMessage
Set objEmailReceivers = .Recipients.Add(Me!lstKontaktEmail)
.Subject = " test"
.Body = "test" & vbCrLf

If Not IsMissing(objAttachment) Then Set objAttachment =
..Attachments.Add(strWordSave)


.Save
.Send
'End If
End With


objOutlook.ActiveWindow
'objOutlook.Quit
Set objOutlook = Nothing

sMal = ""
Set DB = Nothing
Set rec = Nothing
sSql = ""

End Sub

 

[SteveM]

Surely the line: 'If Not rec.BOF Then' should be 'If Not rec.EOF Then'.

That should be changed for a start...

You should test that the Email contains something that represents a valid
email address format e.g. greater than 6 characters, has an @ sign, has at
least one '.' dot...before allowing the code to continue.

Try using ObjMessage.To = Me!lstKontaktEmail instead of Recipients.Add


Steve

 

[JohS]

Thanks for feedback, and Yes, agree in making a test on input and the
correction to EOF.

But, I'll fighting with the .To (but now it ends up in the Inbox, but only
because I'd put in a .CC with a certain address). Did I understand it
correctly when I did as this?









Dim objOutlook As Outlook.Application

Dim objMessage As Outlook.MailItem

'Dim objEmailReceivers As Outlook.Recipient

Dim objAttachment As Outlook.Attachment

Dim strError As String

strError = "Mangler info"

Set objAttachment = strWordSave



Set objOutlook = GetObject(, "Outlook.application")

If objOutlook Is Nothing Then Set objOutlook =
CreateObject("Outlook.application")

Set objMessage = objOutlook.CreateItem(olMailItem)



With objMessage

'Set objEmailReceivers = .Recipients.Add(Me!lstKontaktEmail)

.To = Me!lstKontaktEmail

.CC = "(e-mail address removed)"

.Subject = " test"

.Body = "test" & vbCrLf



If Not IsMissing(objAttachment) Then Set objAttachment =
..Attachments.Add(strWordSave)

'For Each objEmailReceivers In .Recipients

' objEmailReceivers.Resolve

'Next

'.SenderEmailAddress

'.HTMLBody

'.ReadReceiptRequested

.Save

.Send

'End If

End With





objOutlook.ActiveWindow

'objOutlook.Quit

Set objOutlook = Nothing

 

[SteveM]

Do you really want to save the email?
If not, remove the '.Save' line...

Does this code compile?

Here is a snippet of code from one of my apps:

Dim objOutlook As Outlook.Application
Dim objMailItem As Outlook.MailItem

Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(0)

With objMailItem
'Construct email
.To = strEmail
.Body = strBody
.Subject = strSubject
'Add attachments
.Attachments.Add Application.CurrentProject.Path &
"\CoachItinerary.snp"
.Send
End With

'Clean up
'objOutlook.Quit
Set objMailItem = Nothing
Set objOutlook = Nothing

In the above example, I am sending a report snapshot file as an attachment.
You can use the .Attachments.Add line multiple times to add more
attachments...

Steve

 

[JohS]

Apologize for not answering (I was suddenly drowning in some "hurry" work).
The little test I did with the code you sent me didn't work. I suspect
something else could be wrong with the installation I have. Thanks for you
help. I'll come back another time with follow up questions. JohS