How to use multiple variables directly with CDOSYS parameters in Classic ASP - email
I am writing email sending code in Classic ASP using CDOSYS, but what i found when i try to write variables concatenation with CDOSYS parameters its gives me error.
I could not write code in following way-
mail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "admin#" & website
it givees me following error while execution - CDO.Message.1 error '80040213'
while following code works fine as its having single variable-
http://schemas.microsoft.com/cdo/configuration/sendusername") = websiteemail
Note:- Reason to use in that way because my client having many sites and previously we used CDONTS and ASPEMAILS and it used to work fine.
Here is the function I created:
function email(s_from,s_reply_to,s_recipients,s_bcc,s_subject,s_msg,s_type,s_msg_error_add,s_remote_host)
if (s_msg_error_add<>"") then s_msg_error_add = "<hr>" & vbCrLf & s_msg_error_add
if (s_remote_host="default") then s_remote_host = application("s_mail_server")
if (s_remote_host="") then s_remote_host = "localhost"
s_remote_host=lcase(s_remote_host)
's_recipients looks like "Scott <scott#domain.net>; Sue <andy#domain.net>" etc
s_from = replace(s_from,","," ",1,-1,1)
s_from = replace(s_from," "," ",1,-1,1)
s_from = replace(s_from,"[","<",1,-1,1)
s_from = replace(s_from,"]",">",1,-1,1)
if (s_reply_to<>"") then
s_reply_to = replace(s_reply_to,","," ",1,-1,1)
s_reply_to = replace(s_reply_to," "," ",1,-1,1)
s_reply_to = replace(s_reply_to,"[","<",1,-1,1)
s_reply_to = replace(s_reply_to,"]",">",1,-1,1)
end if
s_recipients = replace(s_recipients,",",";",1,-1,1)
s_recipients = replace(s_recipients," "," ",1,-1,1)
s_recipients = replace(s_recipients,"[","<",1,-1,1)
s_recipients = replace(s_recipients,"]",">",1,-1,1)
if (s_bcc<>"") then
s_bcc = replace(s_bcc,","," ",1,-1,1)
s_bcc = replace(s_bcc," "," ",1,-1,1)
s_bcc = replace(s_bcc,"[","<",1,-1,1)
s_bcc = replace(s_bcc,"]",">",1,-1,1)
end if
err.clear
Dim MailerConfig
Dim Mailer
Dim strRet
dim sch
strRet = ""
sch = "http://schemas.microsoft.com/cdo/configuration/"
Set MailerConfig = CreateObject("CDO.Configuration")
Set Mailer = CreateObject("CDO.Message")
With MailerConfig.Fields
'.Item(sch & "sendusing") = 2 'send using port - if err then this is really "SendUsingMethod"
'.Item(sch & "sendusingmethod") = 2 'send using port - if err then this is really "SendUsingMethod"
.Item(sch & "smtpconnectiontimeout") = 900
'.Item(sch & "smtpauthenticate") = 1 'use basic (clear-text) authentication
.Item(sch & "smtpserver") = s_remote_host
'.Item(sch & "smtpserverport") = 25
'.Item(sch & "sendusername") = SMAUTHUSER
'.Item(sch & "sendpassword") = SMAUTHPASS
.Update
End With
Mailer.Configuration = MailerConfig
'Mailer.Fields(cdoImportance) = 1
'Mailer.Fields("urn:schemas:mailheader:X-MSMail-Priority") = 1
'Mailer.Fields("urn:schemas:mailheader:X-Mailer") = ""
'Mailer.Fields.Update
'-- Set the Mail Properties
'on error resume next
Mailer.From = s_from
Mailer.To = s_recipients
if (s_reply_to<>"" and s_reply_to<>"na") then Mailer.ReplyTo = s_reply_to
b_redirect=false
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 72, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_bcc<>"" AND s_bcc<>"na" AND s_bcc<>"n/a") then Mailer.BCC = s_bcc
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 79, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Mailer.Subject = s_subject
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 86, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_type="html") then
Mailer.AutoGenerateTextBody = True
s_msg = replace(s_msg,vbCrLf,"<br>",1,-1,1)
else
Mailer.AutoGenerateTextBody = False
end if
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 103, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Mailer.MimeFormatted = False
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 110, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_type = "text") then
Mailer.TextBody = fn_dirty(s_msg)
else
's_msg_html = replace(s_msg,vbCrLf,"<br>",1,-1,1)
s_msg_html = s_msg
Mailer.HTMLBody = fn_dirty(s_msg_html)
end if
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 123, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
'-- Fire off the email message
Mailer.Send
if (err.number<>0 and err.number<>13) then
Select Case err.Number
Case -2147220973
strRet = " Failure to Send Report Message - Server Not Found" & vbCrLf & " Error: " & err.Number & " - " & err.Description
Case -2147220975
strRet = " Failure to Send Report Message - Server Authentication Failed" & vbCrLf & " Error: " & err.Number & " - " & err.Description
Case Else
strRet = " Failure to Send Report Message - Error: " & err.Number & " - " & err.Description
End Select
msg = "<br>Error in i_fn_email_cdo.asp: " & strRet & "<br><br>"
msg = msg & "remote host = " & s_remote_host & "<br>"
s_from = replace(s_from,"<","[",1,-1,1)
s_from = replace(s_from,">","]",1,-1,1)
s_reply_to = replace(s_reply_to,"<","]",1,-1,1)
s_reply_to = replace(s_reply_to,">","[",1,-1,1)
s_recipients = replace(s_recipients,"<","[",1,-1,1)
s_recipients = replace(s_recipients,">","]",1,-1,1)
s_bcc = replace(s_bcc,"<","[",1,-1,1)
s_bcc = replace(s_bcc,">","]",1,-1,1)
msg = msg & "from = " & s_from & "<br>"
msg = msg & "to = " & s_recipients & "<br>"
msg = msg & "subject = " & s_subject & "<br>"
msg = msg & "recipients = " & s_recipients & "<br><br>"
if (s_type = "text") then
msg = msg & s_msg
else
msg = msg & s_msg_html
end if
msg = msg & "<br>"
msg = msg & s_msg_error_add
session("msg") = msg
Set Mailer = Nothing
set MailerConfig = nothing
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Set Mailer = Nothing
set MailerConfig = nothing
email = true
end function
Related
MS Access running SQL Stored Procedure Write Issue
I have managed to build a Access VBA query that runs a SQL Stored Procedure with parameters and seems to run and complete without incidence, however it does not write the data into the SQL Database. Am I missing a curtail part of coding? The data is gathered from a form. Function AddStaff() Dim adoCN As New ADODB.Connection Dim sConnString As String Dim cmdObjCMD As New ADODB.Command Dim BrandDataTxt Dim StaffNameDataTxt Dim NTloginIDDataTxt Dim NMCUsernameDataTxt Dim StaffAuditLevelDataTxt Dim EmailAddressDataTxt Dim PhoneLoginDataTxt Dim TeamNameDataTxt Dim TeamSegmentDataTxt Dim StartDateDataTxt Dim JobTitleDataTxt DoCmd.OpenForm "AddNewStaff" Forms!AddNewStaff.TBoxBrand.Value = BrandDataTxt Forms!AddNewStaff.TBoxStaffName.Value = StaffNameDataTxt Forms!AddNewStaff.TBoxPCLoginID.Value = NTloginIDDataTxt Forms!AddNewStaff.TBoxNMCUsername.Value = NMCUsernameDataTxt Forms!AddNewStaff.TBoxStaffAuditLevel.Value = CVar(StaffAuditLevelDataTxt) Forms!AddNewStaff.TBoxEmailAddress.Value = EmailAddressDataTxt Forms!AddNewStaff.TBoxPhoneLogin.Value = PhoneLoginDataTxt Forms!AddNewStaff.TBoxTeamName.Value = TeamNameDataTxt Forms!AddNewStaff.TBoxTeamSegment.Value = TeamSegmentDataTxt Forms!AddNewStaff.TBoxStartDate.Value = CDate(StartDateDataTxt) Forms!AddNewStaff.TBoxJobTitle.Value = JobTitleDataTxt Set adoCN = New ADODB.Connection sConnString = "Provider = SQLOLEDB; " & _ "Data Source = KCOMSQL26; " & _ "Initial Catalog = EclipseDW; " & _ "User ID = EclipseDW; " & _ "Password = M1Reporting; " & _ "Trusted_Connection = Yes; " adoCN.Open sConnString With cmdObjCMD .ActiveConnection = sConnString .CommandType = adCmdStoredProc .CommandTimeout = 180 .CommandText = "Staff.usp_AddNewStaffMember" .NamedParameters = True .Parameters("#Brand") = " '" & BrandDataTxt & "'" .Parameters("#StaffPrefName") = " '" & StaffNameDataTxt & "'" .Parameters("#NTLoginID") = " '" & NTloginIDDataTxt & "'" .Parameters("#NMCUsername") = " '" & NMCUsernameDataTxt & "'" .Parameters("#StaffAuditLevel") = " " & StaffAuditLevelDataTxt & "" .Parameters("#EmailAddress") = " '" & EmailAddressDataTxt & "'" .Parameters("#PhoneLogin") = " '" & PhoneLoginDataTxt & "'" .Parameters("#TeamName") = " '" & TeamNameDataTxt & "'" .Parameters("#TeamSegment") = " '" & TeamSegmentDataTxt & "'" .Parameters("#StartDate") = " " & StartDateDataTxt & "" .Parameters("#JobTitle") = " '" & JobTitleDataTxt & "'" .Execute End With adoCN.Close End Function SQL Code EXEC staff.usp_AddNewStaffMember #Brand = 'CSO North' , #StaffPrefName = 'Test Agent' , #NTLoginID = 'TestAgent' , #NMCUsername = 'TestAgent' , #StaffAuditLevel = '1' , #EmailAddress = 'TestAgent#kcom.com' , #PhoneLogin = '99999' , #TeamName = 'Customer Services' , #TeamSegment = 'Customer Services' , #StartDate = '2017-04-18' , #JobTitle = 'Test Agent'
How to test the internet connection behind a proxy?
I have this vbscript that works well on Windows 7 32-bit without proxy In order to improve it, I seek for this solution: How to test internet connection behind a proxy ? The solution perhaps it will be in VBScript or Powershell or Batch, much as I find a way to check whether i am connected or not behind a proxy ! The piece of code to improve it when i'm behind a proxy If there is a trick to check if i'm connected to internet when i'm behind a proxy this is my question ? If CheckConnection = true then Msgbox "i'm connected to internet",vbinformation+vbSystemModal,"Check connection to internet" Else Msgbox "i'm not connected to internet",vbCritical+vbSystemModal,"Check connection to internet" End if '*************************************************************************** Function CheckConnection() CheckConnection = False strComputer = "smtp.gmail.com" Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery _ ("select * from Win32_PingStatus where address = '" & strComputer & "'") For Each objStatus in objPing If objStatus.Statuscode = 0 Then MyLoop = False CheckConnection = True Exit Function End If Next End Function '****************************************************************************** The hole code : Option Explicit Dim Title,MyScriptPath,DJBuzzRadio,MyLoop,strComputer,objPing,objStatus,FSO,FolderScript,URLICON,Icon Title = "Radio DJ Buzz Live by © Hackoo © 2015" MyScriptPath = WScript.ScriptFullName Set FSO = Createobject("Scripting.FileSystemObject") FolderScript = FSO.GetParentFolderName(MyScriptPath) 'Chemin du dossier ou se localise le Vbscript Icon = FolderScript & "\akg.ico" URLICON = ChrW(104)&ChrW(116)&ChrW(116)&ChrW(112)&ChrW(58)&ChrW(47)&ChrW(47)&ChrW(104)&ChrW(97)&ChrW(99)&ChrW(107)&ChrW(111)&ChrW(111)&ChrW(46)&ChrW(97)&ChrW(108)&ChrW(119)&ChrW(97)&ChrW(121)&ChrW(115)&ChrW(100)&ChrW(97)&ChrW(116)&ChrW(97)&ChrW(46)&ChrW(110)&ChrW(101)&ChrW(116)&ChrW(47)&ChrW(97)&ChrW(107)&ChrW(103)&ChrW(46)&ChrW(105)&ChrW(99)&ChrW(111) If Not FSO.FileExists(Icon) Then Call Download(URLICON,Icon) DJBuzzRadio = ChrW(104)&ChrW(116)&ChrW(116)&ChrW(112)&ChrW(58)&ChrW(47)&ChrW(47)&ChrW(119)&ChrW(119)&ChrW(119)&ChrW(46)&ChrW(99)&ChrW(104)&ChrW(111)&ChrW(99)&ChrW(114)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(115)&ChrW(46)&ChrW(99)&ChrW(104)&ChrW(47)&ChrW(100)&ChrW(106)&ChrW(98)&ChrW(117)&ChrW(122)&ChrW(122)&ChrW(114)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(95)&ChrW(119)&ChrW(105)&ChrW(110)&ChrW(100)&ChrW(111)&ChrW(119)&ChrW(115)&ChrW(46)&ChrW(109)&ChrW(112)&ChrW(51)&ChrW(46)&ChrW(97)&ChrW(115)&ChrW(120) Call Shortcut(MyScriptPath,"DJ Buzz Radio") MyLoop = True If CheckConnection = True Then Call AskQuestion() '*************************************************************************** Function CheckConnection() CheckConnection = False While MyLoop = True strComputer = "smtp.gmail.com" Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery _ ("select * from Win32_PingStatus where address = '" & strComputer & "'") For Each objStatus in objPing If objStatus.Statuscode = 0 Then MyLoop = False CheckConnection = True Exit Function End If Next Pause(10) 'To sleep for 10 secondes Wend End Function '*************************************************************************** Sub Play(URL) Dim Sound Set Sound = CreateObject("WMPlayer.OCX") Sound.URL = URL Sound.settings.volume = 100 Sound.Controls.play do while Sound.currentmedia.duration = 0 wscript.sleep 100 loop wscript.sleep (int(Sound.currentmedia.duration)+1)*1000 End Sub '*************************************************************************** Sub Shortcut(CheminApplication,Nom) Dim objShell,fso,DesktopPath,objShortCut,MyTab,strCurDir Set objShell = CreateObject("WScript.Shell") Set fso = CreateObject("Scripting.FileSystemObject") strCurDir = fso.GetParentFolderName(WScript.ScriptFullName) MyTab = Split(CheminApplication,"\") If Nom = "" Then Nom = MyTab(UBound(MyTab)) End if DesktopPath = objShell.SpecialFolders("Desktop") Set objShortCut = objShell.CreateShortcut(DesktopPath & "\" & Nom & ".lnk") objShortCut.TargetPath = Dblquote(CheminApplication) ObjShortCut.IconLocation = strCurDir & "\akg.ico" objShortCut.Save End Sub '***************************************************************************** 'Fonction pour ajouter les doubles quotes dans une variable Function DblQuote(Str) DblQuote = Chr(34) & Str & Chr(34) End Function '***************************************************************************** Function AppPrevInstance() With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2") With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _ " AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'") AppPrevInstance = (.Count > 1) End With End With End Function '****************************************************************************** Function CommandLineLike(ProcessPath) ProcessPath = Replace(ProcessPath, "\", "\\") CommandLineLike = "'%" & ProcessPath & "%'" End Function '****************************************************************************** Sub Pause(NSeconds) Wscript.Sleep(NSeconds*1000) End Sub '****************************************************************************** Sub AskQuestion() Dim Question,MsgAR,MsgFR,MsgEN MsgFR = "Voulez-vous écouter DJ Buzz Radio en direct ?" & vbcr & "Oui = Pour écouter" & vbcr & "Non = Pour arrêter" & vbcr & String(50,"*") MsgEN = "Did you want to listen to the Radio DJ Buzz Live ?" & vbcr & "Yes = To listen" & vbcr & "No = To stop" & vbcr & String(50,"*") MsgAR = ChrW(1607)&ChrW(1604)&ChrW(32)&ChrW(1578)&ChrW(1585)&ChrW(1610)&ChrW(1583)&ChrW(32)&ChrW(1571)&ChrW(1606)&ChrW(32)&ChrW(1578)&ChrW(1587)&ChrW(1605)&ChrW(1593)&ChrW(32)&ChrW(32)&ChrW(1604)&ChrW(1575)&ChrW(1610)&ChrW(1601)&ChrW(32)&ChrW(1585)&ChrW(1575)&ChrW(1583)&ChrW(1610)&ChrW(1608)&ChrW(32)&ChrW(68)&ChrW(74)&ChrW(32)&ChrW(66)&ChrW(117)&ChrW(122)&ChrW(122)&ChrW(32)&ChrW(82)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(32)&ChrW(63) & vbcr & ChrW(1606)&ChrW(1593)&ChrW(1605)&ChrW(32)&ChrW(61)&ChrW(32)&ChrW(1604)&ChrW(1575)&ChrW(1587)&ChrW(1578)&ChrW(1605)&ChrW(1575)&ChrW(1593) & vbcr & ChrW(1604)&ChrW(1575)&ChrW(32)&ChrW(61)&ChrW(32)&ChrW(1604)&ChrW(1608)&ChrW(1602)&ChrW(1601) & vbcr &_ String(50,"*") Question = MsgBox(MsgFR & vbcr & MsgEN & vbcr & MsgAR,vbYesNO+vbQuestion+vbSystemModal,Title) If Question = VbYes And Not AppPrevInstance() Then Call Play(DJBuzzRadio) End If If Question = VbYes And AppPrevInstance() Then MsgBox "There is another instance in execution !" & VbCrLF &_ "Il y a une autre instance en cours d'exécution !"& VbcrLF &_ ChrW(1607)&ChrW(1606)&ChrW(1575)&ChrW(1603)&ChrW(32)&ChrW(1605)&ChrW(1579)&ChrW(1575)&ChrW(1604)&ChrW(32)&ChrW(1570)&ChrW(1582)&ChrW(1585)&ChrW(32)&ChrW(1601)&ChrW(1610)&ChrW(32)&ChrW(1575)&ChrW(1604)&ChrW(1578)&ChrW(1606)&ChrW(1601)&ChrW(1610)&ChrW(1584)& VbcrLF &_ CommandLineLike(WScript.ScriptName),VbExclamation+vbSystemModal,Title WScript.Quit() End If If Question = VbNo And Not AppPrevInstance() Then Call Kill("wscript.exe") End If If Question = VbNo And AppPrevInstance() Then Call Kill("wscript.exe") End If End Sub '****************************************************************************** Sub Kill(MyProcess) Dim Titre,colItems,objItem,Processus,Question Titre = " Processus "& DblQuote(MyProcess) &" en cours d'exécution " Set colItems = GetObject("winmgmts:").ExecQuery("Select * from Win32_Process " _ & "Where Name like '%"& MyProcess &"%' AND commandline like " & CommandLineLike(WScript.ScriptFullName) & "",,48) For Each objItem in colItems objItem.Terminate(0)' Tuer ce processus Next End Sub '****************************************************************************** Sub Download(strFileURL,strHDLocation) Dim objXMLHTTP,objADOStream Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP") objXMLHTTP.open "GET", strFileURL, false objXMLHTTP.send() If objXMLHTTP.Status = 200 Then Set objADOStream = CreateObject("ADODB.Stream") objADOStream.Open objADOStream.Type = 1 'adTypeBinary objADOStream.Write objXMLHTTP.ResponseBody objADOStream.Position = 0 'Set the stream position to the start objADOStream.SaveToFile strHDLocation,2 objADOStream.Close Set objADOStream = Nothing End If Set objXMLHTTP = Nothing Shortcut MyScriptPath,"DJ Buzz Radio" MsgBox "Un raccourci a été crée sur votre bureau !"& vbcr &_ "A shortcut was created on your desktop !"& vbcr &_ ChrW(1578)&ChrW(1605)&ChrW(32)&ChrW(1573)&ChrW(1606)&ChrW(1588)&ChrW(1575)&ChrW(1569)&ChrW(32)&ChrW(1575)&ChrW(1582)&ChrW(1578)&ChrW(1589)&ChrW(1575)&ChrW(1585)&ChrW(32)&ChrW(1593)&ChrW(1604)&ChrW(1609)&ChrW(32)&ChrW(1587)&ChrW(1591)&ChrW(1581)&ChrW(32)&ChrW(1575)&ChrW(1604)&ChrW(1605)&ChrW(1603)&ChrW(1578)&ChrW(1576),vbSystemModal+vbInformation,Title End Sub '**************************************************************************
If you mean the settings of the local computer you can query the registry: REG QUERY "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings" /v ProxyEnable If the value is 0x1 then the there is set proxy. You can check also the proxy value through the value of ProxyServer at the same location. More info here. You can check if your external IP is the same like your internal IP address. This uses winhttpjs.bat for /f "skip=1 tokens=* delims=" %%a in ('winhhttpjs.bat "http://www.telize.com/ip" -saveTo con') do ( set "ip=%%a" ) ipconfig| find "%ip%" || ( echo not real IP/proxy )
Cannot send the emails through the ASP Form
I am unable to send the email through the form because of the following error. I assume that the form doesn't work because of the depricated CDO? I'm not sure, but also I am not sure how to fix this problem. CDO.Message.1 error '80040220' The "SendUsing" configuration value is invalid. /thankyou.asp, line 24 The Code <% Set objMail = Server.CreateObject("CDO.Message") objMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "localhost" objMail.Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 objMail.Configuration.Fields.Update objMail.From = Request.Form("Email") ' change this to an email address objMail.To = "admin#domain.com" ' change this to your email address objMail.Subject = "name Questions/Comments" ' change this to your subject 'Set the e-mail body format (HTMLBody=HTML TextBody=Plain) 'Set the e-mail body format (HTMLBody=HTML TextBody=Plain) objMail.HTMLBody = "<font size=3 face=verdana>" objMail.HTMLBody = objMail.HTMLBody & "<strong>" & "From: " & "</strong>" & Request.form("Name") & "<br>" objMail.HTMLBody = objMail.HTMLBody & "<strong>" & "Email: " & "</strong>" & Request.Form("Email") & "<br>" objMail.HTMLBody = objMail.HTMLBody & "<strong>" & "Phone: " & "</strong>" & Request.Form("Phone") & "<br>" & "<br>" objMail.HTMLBody = objMail.HTMLBody & "<strong>" & "Questions/Comments: " & "</strong>" & "<br>" & Replace(Request.Form("Details"), vbCrLf, "<br />") & "<br>" & "<br>" & "</font>" 'objMail.HTMLBody = objMail.HTMLBody & "<em>" & "Sent at " & Now() & "</em>" & "</font>" objMail.Send() Set objMail = Nothing* %> I don't have the access to the physical server and I cannot change the permissions myself. http://blogs.msdn.com/b/akashb/archive/2010/05/24/error-cdo-message-1-0x80040220-the-quot-sendusing-quot-configuration-value-is-invalid-on-iis-7-5.aspx Any ideas how can I fix this piece of code to make it work again? I have tried this: http://forums.iis.net/t/1146477.aspx?The+SendUsing+configuration+value+is+invalid+ Changing SendUsing to 1. And setting up google snmp to send the emails without much results. Any information would be helpful.
replace your code with this: <% Set cdoConfiguration = Server.CreateObject("CDO.Configuration") With cdoConfiguration .Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "localhost" .Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 .Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60 .Fields.Update End With Dim tmpStr tmpStr = "" tmpStr = "<font size=""3"" face=""verdana"">" tmpStr = tmpStr & "<ul>" tmpStr = tmpStr & "<li><strong>" & "From: " & "</strong>: " & Request.form("Name") & "</li>" tmpStr = tmpStr & "<li><strong>" & "Email: " & "</strong>: " & Request.form("Email") & "</li>" tmpStr = tmpStr & "<li><strong>" & "Phone: " & "</strong>: " & Request.form("Phone") & "</li>" tmpStr = tmpStr & "<li><strong>Questions/Comments</strong>:<br/>" tmpStr = tmpStr & Replace(Request.Form("Details"), vbCrLf, "<br />") tmpStr = tmpStr & "</li>" tmpStr = tmpStr & "</ul>" tmpStr = tmpStr & "<p>Sent at " & Now() & "</p>" tmpStr = tmpStr & "</font>" Set newMailObj = Server.CreateObject("CDO.Message") newMailObj.Configuration = cdoConfiguration newMailObj.Subject = "name Questions/Comments" newMailObj.From = Request.Form("Email") newMailObj.To = "admin#domain.com" newMailObj.HTMLBody = tmpStr newMailObj.Send set newMailObj = nothing set cdoConfiguration = nothing %> and let us know if it works like that, cause if it does, your code (or at least the part you paste to us) is not correct... and, by the way, if you're using localhost I'm almost sure that the server configuration is not necessary... It is obligatory if you use a remote server like smtp.server.com
Intermittent "The transport failed to connect to the server" CDO error
I am writing an application that sends emails to an admin when there is a problem with the data. The account it's sending through is a Network Solutions SMTP server. The code works most of the time, but about 1 out of 10 sends fail with the error -2147220973 "The transport failed to connect to the server". Any suggestions on how to handle this? Set imsg = CreateObject("cdo.message") Set iconf = CreateObject("cdo.configuration") Set Flds = iconf.Fields With Flds .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.OurCompany.com" .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 2525 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "me#OurCompany.com" .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password" .Update End With With imsg Set .Configuration = iconf .To = "me#MyEmail.com" 'CMemail .From = "resupport#OurCompanycom" .Subject = ACT .HTMLBody = "Notification for " & CTName & " of " & CTCname & " " & ACT & ". You must manually Notify them about new docs for " & pname & ". " _ & "<br>Tell " & CTName & " to '" & Nz(DLookup("Notify", "TBLINVOICESETTINGS"), "") & " " & PRName & "_" & pname & ".pdf'" .Send End With Set imsg = Nothing Set iconf = Nothing
Should the smtpserverport be 25, is it being blocked by firewall?
This piece of code executes correctly : Sub SMail(pTO As String, pSB As String, pBO As String, pAT As String) On Error GoTo ErrH: Dim mm As CDO.Message: Set mm = New CDO.Message mm.Configuration.Fields(cdoSMTPUseSSL) = "True" mm.Configuration.Fields(cdoSendUsingMethod) = 2 mm.Configuration.Fields(cdoSMTPAuthenticate) = 1 mm.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com" mm.Configuration.Fields(cdoSendUserName) = "MyID" mm.Configuration.Fields(cdoSendPassword) = "MyPW" 'mm.Configuration.Fields(cdoSMTPConnectionTimeout) = 20 'mm.Configuration.Fields(cdoSMTPServerPort) = 25 mm.Configuration.Fields.Update mm.From = "MyID" mm.To = pTO mm.Subject = pSB mm.TextBody = pBO mm.AddAttachment (pAT) mm.send ErrH: If Err Then MsgBox (Err.Number & " : " & Err.Description) Set mm = Nothing End Sub
VB 6 failed send to email server
I am trying to write a program that will send email with an attachment in VB6. I'm using winsock and smtp.gmail.com as my mail server but it doesn't work. Failed to connect to mail server.The code works fine. My only problem is when I try to send message it doesn't connect please help me thanks in advance. Here's the code Dim objBase64 As New Base64 Dim bTrans As Boolean Dim m_iStage As Integer Dim Sock As Integer Dim RC As Integer Dim Bytes As Integer Dim ResponseCode As Integer Dim path As String Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Const OFN_READONLY = &H1 Const OFN_OVERWRITEPROMPT = &H2 Const OFN_HIDEREADONLY = &H4 Const OFN_NOCHANGEDIR = &H8 Const OFN_SHOWHELP = &H10 Const OFN_ENABLEHOOK = &H20 Const OFN_ENABLETEMPLATE = &H40 Const OFN_ENABLETEMPLATEHANDLE = &H80 Const OFN_NOVALIDATE = &H100 Const OFN_ALLOWMULTISELECT = &H200 Const OFN_EXTENSIONDIFFERENT = &H400 Const OFN_PATHMUSTEXIST = &H800 Const OFN_FILEMUSTEXIST = &H1000 Const OFN_CREATEPROMPT = &H2000 Const OFN_SHAREAWARE = &H4000 Const OFN_NOREADONLYRETURN = &H8000 Const OFN_NOTESTFILECREATE = &H10000 Const OFN_NONETWORKBUTTON = &H20000 Const OFN_NOLONGNAMES = &H40000 Const OFN_EXPLORER = &H80000 Const OFN_NODEREFERENCELINKS = &H100000 Const OFN_LONGNAMES = &H200000 Const OFN_SHAREFALLTHROUGH = 2 Const OFN_SHARENOWARN = 1 Const OFN_SHAREWARN = 0 Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long Private Declare Function timeGetTime Lib "winmm.dll" () As Long Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const MF_BYPOSITION = &H400& Const MF_REMOVE = &H1000& Dim Mime As Boolean Dim arrRecipients As Variant Dim CurrentE As Integer Private Sub Attachment_Click() path = SaveDialog(Me, "*.*", "Attach File", App.path) If path = "" Then Exit Sub AttachmentList.AddItem path Mime = True AttachmentList.ListIndex = AttachmentList.ListCount - 1 End Sub Private Sub AttachmentList_Click() fSize = Int((FileLen(AttachmentList) / 1024) * 100 + 0.5) / 100 AttachmentList.ToolTipText = AttachmentList & " (" & fSize & " KB)" End Sub Private Sub AttachmentList_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) For I = 1 To Data.Files.Count If (GetAttr(Data.Files.Item(I)) And vbDirectory) = 0 Then AttachmentList.AddItem Data.Files.Item(I): Mime = True: AttachmentList.ListIndex = AttachmentList.ListCount - 1 Next I End Sub Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim MsgBuffer As String * 2048 On Error Resume Next If Sock > 0 Then Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0) If Bytes > 0 Then ServerResponse = Mid$(MsgBuffer, 1, Bytes) DataArrival = DataArrival & ServerResponse & vbCrLf DataArrival.SelStart = Len(DataArrival) If bTrans Then If ResponseCode = Left$(MsgBuffer, 3) Then m_iStage = m_iStage + 1 Transmit m_iStage Else closesocket (Sock) Call EndWinsock Sock = 0 Process = "The Server responds with an unexpected Response Code!" Exit Sub End If End If ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then closesocket (Sock) Call EndWinsock Sock = 0 End If End If Refresh End Sub Private Sub delattach_Click() If AttachmentList.ListCount = 0 Or AttachmentList.ListIndex = -1 Then Exit Sub tmpIndex = AttachmentList.ListIndex AttachmentList.RemoveItem (AttachmentList.ListIndex) If AttachmentList.ListCount = 0 Then Mime = False: Attachment.ToolTipText = "Drag & Drop your attachments here" Else If AttachmentList.ListIndex = 0 Then AttachmentList.ListIndex = tmpIndex Else AttachmentList.ListIndex = tmpIndex - 1 End Sub Sub DisableX(frm As Form) Dim hMenu As Long Dim nCount As Long hMenu = GetSystemMenu(frm.hWnd, 0) nCount = GetMenuItemCount(hMenu) Call RemoveMenu(hMenu, nCount - 1, MF_REMOVE Or MF_BYPOSITION) Call RemoveMenu(hMenu, nCount - 2, MF_REMOVE Or MF_BYPOSITION) DrawMenuBar frm.hWnd End Sub Private Sub Exit_Click() On Error Resume Next Call Startrek closesocket Sock Call EndWinsock End End Sub Private Sub Form_Load() Call DisableX(Me) End Sub Function IsConnected2Internet() As Boolean On Error Resume Next If MyIP = "127.0.0.1" Or MyIP = "" Then IsConnected2Internet = False Else IsConnected2Internet = True End Function Function SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String Dim ofn As OPENFILENAME Dim A As Long ofn.lStructSize = Len(ofn) ofn.hwndOwner = Form1.hWnd ofn.hInstance = App.hInstance If Right$(Filter, 1) <> "|" Then Filter = Filter & "|" For A = 1 To Len(Filter) If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0) Next A ofn.lpstrFilter = Filter ofn.lpstrFile = Space$(254) ofn.nMaxFile = 255 ofn.lpstrFileTitle = Space$(254) ofn.nMaxFileTitle = 255 ofn.lpstrInitialDir = InitDir ofn.lpstrTitle = Title ofn.flags = OFN_HIDEREADONLY Or OFN_CREATEPROMPT A = GetSaveFileName(ofn) If (A) Then SaveDialog = Left$(Trim$(ofn.lpstrFile), Len(Trim$(ofn.lpstrFile)) - 1) Else SaveDialog = "" End If End Function Private Sub SendMimeAttachment() Dim FileIn As Long Dim temp As Variant Dim s As Variant Dim TempArray() As Byte Dim Encoded() As Byte Dim strFile As String Dim strFile1 As String * 32768 For IAT = 0 To AttachmentList.ListCount - 1 path = AttachmentList.List(IAT) Mimefilename = Trim$(Right$(path, Len(path) - InStrRev(path, "\"))) FileIn = FreeFile r temp = vbCrLf & "--NextMimePart" & vbCrLf temp = temp & "Content-Type: application/octet-stream; name=Mimefilename" & vbCrLf temp = temp & "Content-Transfer-Encoding: base64" & vbCrLf temp = temp & "Content-Disposition: attachment; filename=" & Chr$(34) & Mimefilename & Chr$(34) & vbCrLf WinsockSendData (temp & vbCrLf) Open path For Binary Access Read As FileIn If GetSetting(App.Title, "Settings", "Too big", "") <> "True" Then If LOF(FileIn) > 2097152 Then fSize = Int((LOF(FileIn) / 1048576) * 100 + 0.5) / 100 Setu = MsgBox("The current file is " & fSize & " MB of size, extracting from it could take a few minutes, Click Yes to go ahead, No to skip it or Cancel if you don't want to get this message again", vbYesNoCancel) If Setu = vbYes Then GoTo Cont If Setu = vbNo Then Close (FileIn): GoTo Anoth Else SaveSetting App.Title, "Settings", "Too big", "True" End If End If Cont: frm2.Visible = True Process = "Loading """ & AttachmentList.List(IAT) & """" Do While Not EOF(FileIn) If LOF(FileIn) = 0 Then GoTo Anoth Get FileIn, , strFile1 strFile = strFile & Mid$(strFile1, 1, Len(strFile1) - (Loc(FileIn) - LOF(FileIn))) strFile1 = "" DoEvents frm2.Width = (3300 / 100) * (Len(strFile) * 50 / LOF(FileIn)) lblpcent = Int(Len(strFile) * 50 / LOF(FileIn)) & "%" If Cancelflag Then Close FileIn: Exit Sub Loop Close FileIn If strFile = "" Then Exit Sub objBase64.Str2ByteArray strFile, TempArray objBase64.EncodeB64 TempArray, Encoded objBase64.Span 76, Encoded, TempArray strFile = "" s = StrConv(TempArray, vbUnicode) For I = 1 To Len(s) Step 8192 ss = Trim$(Mid$(s, I, 8192)) tmpServerSpeed = 150 Start = timeGetTime Do DoEvents Loop Until timeGetTime >= Start + tmpServerSpeed * 20 WinsockSendData (ss) frm2.Width = 1650 + (3300 / 100) * ((I + Len(ss)) * 50 / Len(s)) lblpcent = 50 + Int((I + Len(ss)) * 50 / Len(s)) & "%" Process = "Sending " & Mimefilename & "... " & I + Len(ss) & " Bytes from " & Len(s) DoEvents Next I Anoth: s = "" Next IAT WinsockSendData (vbCrLf & "--NextMimePart--" & vbCrLf) WinsockSendData (vbCrLf & "." & vbCrLf) End Sub Private Sub SendMimeConnect_Click() If Tobox = "" Or InStr(Tobox, "#") = 0 Then MsgBox "To: Is not correct!" Exit Sub End If If IsConnected = False Then If MsgBox("No Internet connection has been detected, check for Update anyway?", vbYesNo) = vbNo Then Exit Sub End If Sock = ConnectSock(MailServer, 25, DataArrival.hWnd) If Sock = SOCKET_ERROR Then Process = "Cannot Connect to " & MailServer & GetWSAErrorString(WSAGetLastError()) closesocket Sock Call EndWinsock Exit Sub End If Process = "Connected to " & MailServer bTrans = True m_iStage = 0 DataArrival = "" ResponseCode = 220 Call WaitForResponse End Sub Sub SendMimetxt(txtFrom, txtTo, txtSubjekt, txtMail) Dim strToSend As String Dim strDataToSend As String If Mime Then strDataToSend = "From: " & txtFrom & vbCrLf strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf strDataToSend = strDataToSend & "Mime-Version: 1.0" & vbCrLf strDataToSend = strDataToSend & "Content-Type: multipart/mixed; boundary=NextMimePart" & vbCrLf strDataToSend = strDataToSend & "Content-Transfer-Encoding: 7bit" & vbCrLf strDataToSend = strDataToSend & "This is a multi-part message in MIME format." & vbCrLf & vbCrLf strDataToSend = strDataToSend & "--NextMimePart" & vbCrLf & vbCrLf strDataToSend = strDataToSend & Trim$(Mailtxt) strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf) For I = 1 To Len(strDataToSend) Step 8192 strToSend = Trim$(Mid$(strDataToSend, I, 8192)) WinsockSendData (strToSend) frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend)) lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%" If Cancelflag Then Exit For Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend) DoEvents Next I SendMimeAttachment Else strDataToSend = "From: " & txtFrom & vbCrLf strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf & vbCrLf strDataToSend = strDataToSend & Trim$(txtMail) strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf) For I = 1 To Len(strDataToSend) Step 8192 strToSend = Trim$(Mid$(strDataToSend, I, 8192)) WinsockSendData (strToSend) frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend)) lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%" If Cancelflag Then Exit For Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend) DoEvents Next I WinsockSendData (vbCrLf & "." & vbCrLf) End If End Sub Sub Startrek() On Error Resume Next Dim Rate As Integer Dim Rate2 As Integer If WindowState <> 0 Then Exit Sub Caption = "End Transmission" GotoVal = (Height / 12) Rate = 50 For Gointo = 1 To GotoVal Spd = Timer Rate2 = Rate / 2 Height = Height - Rate Top = Top + Rate2 DoEvents Width = Width - Rate Left = Left + Rate2 DoEvents If Width <= 2000 Then Exit For Rate = (Timer - Spd) * 10000 Next Gointo WindowState = 1 End Sub Private Sub Tobox_Change() arrRecipients = Split(Tobox, ",") End Sub Private Sub Transmit(iStage As Integer) Dim Helo As String Dim pos As Integer Select Case m_iStage Case 1 Helo = Frombox pos = Len(Helo) - InStr(Helo, "#") Helo = Right$(Helo, pos) ResponseCode = 250 WinsockSendData ("HELO " & Helo & vbCrLf) Call WaitForResponse Case 2 ResponseCode = 250 WinsockSendData ("MAIL FROM: <" & Trim$(Frombox) & ">" & vbCrLf) Call WaitForResponse Case 3 ResponseCode = 250 WinsockSendData ("RCPT TO: <" & Trim$(arrRecipients(CurrentE)) & ">" & vbCrLf) Call WaitForResponse Case 4 ResponseCode = 354 WinsockSendData ("DATA" & vbCrLf) Call WaitForResponse Case 5 ResponseCode = 250 Call SendMimetxt(Frombox, Trim$(arrRecipients(CurrentE)), Subjekt, Mailtxt) Call WaitForResponse Case 6 ResponseCode = 221 WinsockSendData ("QUIT" & vbCrLf) Call WaitForResponse Process = "Email has been sent!" frm2.Width = 3300 lblpcent = "100%" DataArrival = "" m_iStage = 0 If arrRecipients(CurrentE + 1) <> "" Then CurrentE = CurrentE + 1 SendMimeConnect_Click Else bTrans = False CurrentE = 0 End If End Select End Sub Private Sub WaitForResponse() Dim Start As Long Dim Tmr As Long Start = timeGetTime While Bytes > 0 Tmr = timeGetTime - Start DoEvents ' If Tmr > 20000 Then Process = "SMTP service error, timed out while waiting for response" End If Wend End Sub Private Sub WinsockSendData(DatatoSend As String) Dim RC As Integer Dim MsgBuffer As String * 8192 MsgBuffer = DatatoSend RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0) If RC = SOCKET_ERROR Then Process = "Cannot Send Request." & Str$(WSAGetLastError()) & _ GetWSAErrorString(WSAGetLastError()) closesocket Sock Call EndWinsock Exit Sub End If End Sub
I didn't bother to read your code. Too hard. Here's how to do it easily. Set emailObj = CreateObject("CDO.Message") emailObj.From = "dc#gail.com" emailObj.To = "dc#gail.com" emailObj.Subject = "Test CDO" emailObj.TextBody = "Test CDO" emailObj.AddAttachment "c:\windows\win.ini" Set emailConfig = emailObj.Configuration emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com" emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "YourUserName" emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Password1" emailConfig.Fields.Update emailObj.Send If err.number = 0 then Msgbox "Done" Here's how to get files from internet with a high level object. You must use the exact name with http:// as there no helper for incorrect addresses. Set File = WScript.CreateObject("Microsoft.XMLHTTP") File.Open "GET", "http://www.microsoft.com", False File.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.0; Trident/4.0; SLCC1; .NET CLR 2.0.50727; Media Center PC 5.0; .NET CLR 1.1.4322; .NET CLR 3.5.30729; .NET CLR 3.0.30618; .NET4.0C; .NET4.0E; BCD2000; BCD2000)" File.Send txt=File.ResponseText Also for binary files use ado stream. To create a database in memory use adodb recordset (better than a dictionary, array, or a collection), makes sorting a one line command.