we have migrated from a shared Exchange email host to Office 365. We have some old SQL2000 DTS Active X scripts (vbscript) sending mail that have quit working now. We are sending using CDO and connecting with SMTP. I don't believe anything on the server or our network have changed, but not 100% sure. Below is the vbscript. We are getting a "transport failed to connect to the server" error on the .Send line. Any ideas on how to fix this?
'**********************************************************************
' Visual Basic ActiveX Script
'************************************************************************
Function Main()
'# Get a preconfigured "CDO.Message" object
Set oMail = GetCdoMessageObject()
'# Send email
With oMail
.From = "mailsend#ourdomain.com"
.To = "me#ourdomain.com"
.Subject = "test to cfoster#ourdomain.coml"
.TextBody = "This message was sent from a DTS package."
.HtmlBody = "<div><p>This <i>message</i> was sent from a <b>DTS</b> package.</p></div>"
.Send
End With
'# Clean Up
Set oMail = Nothing
'# Return
Main = DTSTaskExecResult_Success
End Function
Function GetCdoMessageObject()
Dim CdoMessage
Set CdoMessage = CreateObject("CDO.Message")
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'CdoSendUsingPort
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") ="smtp.office365.com"
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True 'Use SSL for the connection (True or False)
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'cdoBasic
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") ="mailsend#ourdomain.com"
CdoMessage.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") ="passwordhere"
CdoMessage.Configuration.Fields.Update
Set GetCdoMessageObject = CdoMessage
End Function
I found that if I specified SSL true then I had to comment out the line specifying port 587.
Related
I have a script to run via the task scheduler that checks for unread emails and sends an email alert as shown below. To further enhance this, I need to be able to check the unread emails and only send the email if they are older than 'x' minutes.
Any thoughts on how best to accomplish this?
Thanks
see updated code further below with inclusion of suggested code in answer - however this causes a syntax error
Const olFolderInbox = 6
Const olMailItem = 0
dim objOutlook
call checkForUnreadMails
sub checkForUnreadMails()
dim objFolder, objNamespace
'get running outlook application or open outlook
Set objOutlook = GetObject(, "Outlook.Application")
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
Set objNamespace = objOutlook.GetNamespace("MAPI")
'get inbox folder
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
'send mail if more than 10 mails are unread
if objFolder.UnReadItemCount > 10 then
sendMail "email#emailaddress.com"
end if
end sub
sub sendMail(address)
dim oItem
Set oItem = objOutlook.CreateItem(olMailItem)
With oItem
.To = address
.Subject = "There are unread emails"
.Body = "Please investigate the mailbox."
.send
End With
end sub
Edited version below:
Const olFolderInbox = 6
Const olMailItem = 0
dim objOutlook
call checkForUnreadMails
sub checkForUnreadMails()
dim objFolder, objNamespace
'get running outlook application or open outlook
Set objOutlook = GetObject(, "Outlook.Application")
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
Set objNamespace = objOutlook.GetNamespace("MAPI")
'get inbox folder
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
'look at unread emails
Set UnreadItems = objFolder.Items
'send mail if mails are unread and older than 15 mins
For i = UnreadItems.Count To 1 Step -1
If TypeName(UnreadItems.Item(i)) = "MailItem" Then
If DateDiff("n",now, UnreadItems.Item(i).ReceivedTime) > 15 Then
sendMail "mail#address.com"
end if
end if
Next
sub sendMail(address)
dim oItem
Set oItem = objOutlook.CreateItem(olMailItem)
With oItem
.To = address
.Subject = "There are unread emails"
.Body = "Please investigate the mailbox."
.send
End With
end sub
This should work:
Set UnreadItems = objFolder.Items
For i = UnreadItems.Count To 1 Step -1
If TypeName(UnreadItems.Item(i)) = "MailItem" Then
If DateDiff("n",now, UnreadItems.Item(i).ReceivedTime) > 15 Then
//Do something
End If
End If
Next
Do not use Outlook Object Model from the Task Scheduler - it runs as a service, and no Office app (Outlook included) can be used from a service. Your code will break sooner or later.
I am using a server side script using CDO on Network solution that is now failing with a '500 server error' Have they changed their Windows servers?
This code works fine on some other domains hosted by Network solutions. I tried changing to localhost and the server port to 25 with no luck.
<%#LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<%
Dim cdoConfig, cdoMessage, sch, nProfileID, sFName, sLName, sEmail, sBCC, sFromEmail, sMessage, Optin
nProfileID = Request.Form("profileID")
sFName = Request.Form("fname")
sLName = Request.Form("lname")
sFromEmail = Request.Form("email")
sMessage = Request.Form("message")
Optin = Request.Form("optin")
'sAction = "email_form_work.asp?profileID=" & nProfileID
sEmail = "m.hill#secretagency.com" 'generic email account *** change to info#bglawde.com
sBCC = "hillcreative#comcast.net"
sch = "http://schemas.microsoft.com/cdo/configuration/"
Set cdoConfig = CreateObject("CDO.Configuration")
With cdoConfig.Fields
'Set CDO Port
.Item(sch & "sendusing") = 1
'Set mailserver name either IP address, mail.yoursite.com or localhost
.Item(sch & "smtpserver") = "smtp.secretagency.com"
'Set SMTP port which is 25 by default
.Item(sch & "smtpserverport") = 2525
'Set number of seconds before timeout
.Item(sch & "smtpconnectiontimeout") = 60
.update
End With
Set cdoMessage = CreateObject("CDO.Message")
With cdoMessage
Set .Configuration = cdoConfig
.From = sFromEmail
.To = sEmail
.CC = ""
'use this to send a blind copy
.BCC = sBCC
.Subject = ""
'Send the email in text format *comment out HTML
.TextBody = sFName & " " & sLName & " has sent you the following message:" & vbCRLF & vbCRLF & sMessage & vbCRLF
.Send
End With
set cdoMessage = nothing
set cdoConfig = nothing
'************ Mail ends here ********************
%>
Problem solved. Network solutions Windows Server will only work with CDO when employing Authentication:
cdoSMTPAuthenticate, cdoSendUsername, cdoSendPassword must be defined.
since last week, I am no longer able to send email via gmail's smtp server. I get the error " -2147220973 the transport failed to connect to the server" whenever I try to send email. However, if I try using my another network (ex. my mobile broadband) it works.
Below is my code for sending email.
Set cdomsg = CreateObject("CDO.Message")
Set cdoconf = CreateObject("CDO.Configuration")
cdoconf.Load -1 ' CDO Source Defaults
Set cdoFields = cdoconf.Fields
With cdoFields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "example#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "abc"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Update
End With
What is the possible problem? Thank you.
Here is my environment: Windows Server 2003, Microsoft Access 2003, Microsoft VB 6.5
Trying to send email from Access using CDO.Message. Here is the portion of my code:
Private Sub btnTestEmail_Click()
On Error GoTo SendMail_Error:
Dim Mailmsg As Object
Dim mailconf As Object
Dim McFields As Object
Dim strSchemas As String
Set Mailmsg = CreateObject("CDO.Message")
Set mailconf = CreateObject("CDO.Configuration")
Set McFields = mailconf.Fields
strSchemas = "http://schemas.microsoft.com/cdo/configuration/"
With McFields
.Item(strSchemas & "sendusing") = 2
.Item(strSchemas & "smtpserver") = "smtp.gmail.com"
.Item(strSchemas & "smtpserverport") = 465
.Item(strSchemas & "smtpauthenticate") = 1
.Item(strSchemas & "sendusername") = "my_email#gmail.com"
.Item(strSchemas & "sendpassword") = "my_gmail_password"
.Item(strSchemas & "smtpconnectiontimeout") = 60
.Item(strSchemas & "smtpusessl") = 1
.Update
End With
Set Mailmsg.Configuration = mailconf
With Mailmsg
.TextBody = "Test email body text"
.Subject = "Test email subject"
.To = "target_email#gmail.com"
.from = "my_email#gmail.com"
'.AddAttachment "D:\test.pdf"
.Fields("urn:schemas:mailheader:disposition-notification-to") = "my_email#gmail.com"
.Fields("urn:schemas:mailheader:return-receipt-to") = "my_email#gmail.com"
' Set delivery status notification (DSN)
' Name Value Description
' cdoDSNDefault 0 No DSN commands are issued.
' cdoDSNNever 1 No DSN commands are issued.
' cdoDSNFailure 2 Return a DSN if delivery fails.
' cdoDSNSuccess 4 Return a DSN if delivery succeeds.
' cdoDSNDelay 8 Return a DSN if delivery is delayed.
' cdoDSNSuccessFailOrDelay 14 Return a DSN if delivery succeeds, fails, or is
.DSNOptions = 0
.Fields.Update
.Send
End With
MsgBox "Message Sent", vbOKOnly
Set Mailmsg = Nothing
Set mailconf = Nothing
Set McFields = Nothing
Exit Sub
SendMail_Error:
MsgBox Err.Description, vbOKOnly
End Sub
With DSNOptions = 0 works great but I would like to get delivery notification (not read notification).
If I set DSNOptions to any allowed non-zero value the email doesn't even arrives to the target email and I don't get any notification to my email.
Strange thing if I set unexisting target email (on purpose) I get delivery unsuccessful notification even with DSNOptions = 0.
Am I missing something in the code? Found on multiple other web site people claims this code works but using other smtp servers. Any help appreciated.
Image --> http://i.stack.imgur.com/bKvVv.jpg
When I use the following script to connect to an exchange mail server to send my email message I am prompted by the above login window asking for domain credentials. How do I automate my script so I dont get that login window. The workstation sending the email isnt joined to an AD domain.
Function sendMail(a,b,c)
set objMsg = CreateObject("CDO.Message")
set objConf = CreateObject("CDO.Configuration")
Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "email server name"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = a
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = b
.Update
End With
strBody = "Script has finished running, 6005 is finished"
With objMsg
Set .Configuration = objConf
.To = c
.From = c
.Subject = "[AUTO] Script has finished running!"
.TextBody = strBody
.Fields.update
.Send
End With
End Function
sendMail "username","password","my email address"
Thanks
John
With the line
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 2
you are requesting NTLM authentication. This probably causes the login dialog to be displayed.
Please try this instead:
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
This causes the sendusername and sendpassword fields to be used, with "basic authentication". Please note that some email servers are configured to reject "basic authentication".