VBA Access - Outlook

  • Thread starter Thread starter JohS
  • Start date Start date
J

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
 
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
 
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
 
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
 
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
 
Back
Top