Redemption Query - Messages not being sent

  • Thread starter Thread starter Chris
  • Start date Start date
C

Chris

Hi,

I am an inexperienced Access programmer and having a slight issue with
some code. I can't get messages to send using redemption. They are
being saved in my inbox and state "This message has not being sent."

Before I added the redemption code in, the database sent e-mails OK
(albeit I had to click the security warning for each message).

Can anyone advise how to send the messages from my inbox. I don't
usually have Outlook running as I use Outlook Express at home.
Outlook is simply used to send these messages. I am using Win XP Pro
and outlook/Access 2003.

The code is below:

Thanks in anticipation for your help.

Chris

===

Private Function SendMail(strTo, strMessage, strSubject)

Dim dbmydb As Database
Dim rsmyrs As Recordset
Dim objOutlook
Dim olMailItem
Dim objMail
Dim safemail As Variant
Dim CurrentUser
Dim Utils

'Create a new MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objMail = objOutlook.CreateItem(olMailItem)
Set safemail = CreateObject("Redemption.SafeMailItem")
Set safemail.Item = objMail

'On Error GoTo CheckError

'Create the message
With safemail
.Importance = 2
.To = strTo
.Subject = strSubject
.Body = "" & strMessage & ""

'Send the message
.Send
End With

Set Utils = CreateObject("Redemption.MAPIUtils")
Utils.DeliverNow

'Clear Objects
Set objOutlook = Nothing
Set olMailItem = Nothing
Set objMail = Nothing
Set safemail = Nothing
Set Utils = Nothing

Exit Function


CheckError:

Set dbmydb = DBEngine(0)(0)

'Create a new MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objMail = objOutlook.CreateItem(olMailItem)
Set safemail = CreateObject("Redemption.SafeMailItem")
Set safemail.Item = objMail

'Create the message
With safemail
.Importance = 2
.To = "(e-mail address removed)" ' sample e-mail address
.Subject = "Error Sending e-mail to " & strTo & "."
.Body = "This message was not delivered" & vbCrLf & vbCrLf &
strMessage & ""

.Recipients.Resolveall
'Send the message
.Send
Set Utils = CreateObject("Redemption.MAPIUtils")
Utils.DeliverNow
End With

'Clear Objects
Set objOutlook = Nothing
Set olMailItem = Nothing
Set objMail = Nothing
Set safemail = Nothing
Set Utils = Nothing

End Function
 
Back
Top