McKilty
2009-12-11 16:21:51 UTC
I use this routine in several apps. If Outlook is not open on the
machine, it opens it behind the scenes and sends an e-mail, but the e-
mail stays in the drafts folder until I open Outlook manually.
I've tried DoEvents and a Sleep fucntion between the Send and the
Outlook Close, but it doesn't help. How can I alter this code that
that the e-mail ise sent.
********************************************************************************************
Public Sub Send_Auto_Email(Optional SendTo As String, Optional SendCc
As String, Optional SendBcc As String, Optional mySubject As String,
Optional myBody As String, Optional SendTime As Date, Optional
NextSendTime As Date, Optional SendOnBehalfOf As String, Optional AID
As Long, Optional EMPID As String)
Dim oItem, SafeItem, myNameSpace
Dim myOutlook As Outlook.Application
Dim blnWeCreated As Boolean
On Error Resume Next
blnWeCreated = False
Set myOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If myOutlook Is Nothing Then
blnWeCreated = True
Set myOutlook = New Outlook.Application
End If
Set myNameSpace = myOutlook.GetNamespace("MAPI")
myNameSpace.Logon
Set SafeItem = CreateObject("Redemption.SafeMailItem")
Set oItem = myOutlook.CreateItem(0)
SafeItem.Item = oItem 'set Item property
SafeItem.Subject = mySubject
SafeItem.To = SendTo
SafeItem.CC = SendCc
SafeItem.BCC = SendBcc
SafeItem.Recipients.ResolveAll
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "D) Subject",
mySubject
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "E) To", SendTo
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "F) CC", SendCc
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "G) BCC", SendBcc
If Len(SendOnBehalfOf) > 0 Then
SafeItem.SentOnBehalfOfName = SendOnBehalfOf
End If
SafeItem.Body = myBody & EmailFooter(SendTime, NextSendTime)
SafeItem.Send
If blnWeCreated = True Then
myOutlook.Quit
End If
Set oItem = Nothing
Set SafeItem = Nothing
Set myOutlook = Nothing
Exit Sub
ErrorHandler:
SaveSetting App.Title, "Log\" & EMPID & "\" & AID & "\Error",
"Number", Err.Number
SaveSetting App.Title, "Log\" & EMPID & "\" & AID & "\Error",
"Description", Err.Description
If Err.Description = "You do not have the permission to send the
message on behalf of the specified user." Then
SafeItem.SentOnBehalfOfName = ""
SafeItem.Body = myBody
SafeItem.Body = SafeItem.Body & vbCrLf & vbCrLf & vbCrLf _
&
"*************************************************************************"
& vbCrLf _
& "THIS E-MAIL WAS SUPPOSED TO BE SENT ON BEHALF OF ' " & UCase
(SendOnBehalfOf) & " ' , BUT THE SQL ADMIN HAS NOT BEEN GIVEN THOSE
RIGHTS."
SafeItem.Body = SafeItem.Body & EmailFooter(SendTime, NextSendTime)
SafeItem.BCC = SendBcc & "; " & SendOnBehalfOf
Resume
Else
MsgBox Err.Number & " " & Err.Description
Exit Sub
End If
End Sub
********************************************************************************************
machine, it opens it behind the scenes and sends an e-mail, but the e-
mail stays in the drafts folder until I open Outlook manually.
I've tried DoEvents and a Sleep fucntion between the Send and the
Outlook Close, but it doesn't help. How can I alter this code that
that the e-mail ise sent.
********************************************************************************************
Public Sub Send_Auto_Email(Optional SendTo As String, Optional SendCc
As String, Optional SendBcc As String, Optional mySubject As String,
Optional myBody As String, Optional SendTime As Date, Optional
NextSendTime As Date, Optional SendOnBehalfOf As String, Optional AID
As Long, Optional EMPID As String)
Dim oItem, SafeItem, myNameSpace
Dim myOutlook As Outlook.Application
Dim blnWeCreated As Boolean
On Error Resume Next
blnWeCreated = False
Set myOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If myOutlook Is Nothing Then
blnWeCreated = True
Set myOutlook = New Outlook.Application
End If
Set myNameSpace = myOutlook.GetNamespace("MAPI")
myNameSpace.Logon
Set SafeItem = CreateObject("Redemption.SafeMailItem")
Set oItem = myOutlook.CreateItem(0)
SafeItem.Item = oItem 'set Item property
SafeItem.Subject = mySubject
SafeItem.To = SendTo
SafeItem.CC = SendCc
SafeItem.BCC = SendBcc
SafeItem.Recipients.ResolveAll
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "D) Subject",
mySubject
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "E) To", SendTo
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "F) CC", SendCc
SaveSetting App.Title, "Log\" & EMPID & "\" & AID, "G) BCC", SendBcc
If Len(SendOnBehalfOf) > 0 Then
SafeItem.SentOnBehalfOfName = SendOnBehalfOf
End If
SafeItem.Body = myBody & EmailFooter(SendTime, NextSendTime)
SafeItem.Send
If blnWeCreated = True Then
myOutlook.Quit
End If
Set oItem = Nothing
Set SafeItem = Nothing
Set myOutlook = Nothing
Exit Sub
ErrorHandler:
SaveSetting App.Title, "Log\" & EMPID & "\" & AID & "\Error",
"Number", Err.Number
SaveSetting App.Title, "Log\" & EMPID & "\" & AID & "\Error",
"Description", Err.Description
If Err.Description = "You do not have the permission to send the
message on behalf of the specified user." Then
SafeItem.SentOnBehalfOfName = ""
SafeItem.Body = myBody
SafeItem.Body = SafeItem.Body & vbCrLf & vbCrLf & vbCrLf _
&
"*************************************************************************"
& vbCrLf _
& "THIS E-MAIL WAS SUPPOSED TO BE SENT ON BEHALF OF ' " & UCase
(SendOnBehalfOf) & " ' , BUT THE SQL ADMIN HAS NOT BEEN GIVEN THOSE
RIGHTS."
SafeItem.Body = SafeItem.Body & EmailFooter(SendTime, NextSendTime)
SafeItem.BCC = SendBcc & "; " & SendOnBehalfOf
Resume
Else
MsgBox Err.Number & " " & Err.Description
Exit Sub
End If
End Sub
********************************************************************************************