Excel VBA CDO Message Email 发送账户的工作越来越少了……
Excel VBA CDO Message Email Sending accounts work less and less…
你好
我一直在尝试使用一些 CDO 消息 VBA 编码来自动发送简短的电子邮件。全部供私人使用，每天最多发送几封电子邮件。电子邮件要么是给我家人的，要么是我与之共享编码的其他人，例如在免费帮助论坛上。
我的宏确实有效，而且在过去非常可靠。
最近我发现越来越多的电子邮件帐户不再有效。所以我必须用另一个替换发送电子邮件帐户。
我 运行 没有可用的帐户。
新帐户要么不起作用，要么只工作几次，然后在进一步尝试时会出现各种错误。
我使用的来自同一提供商的不同帐户都具有相同的设置，并且在某些情况下以前以类似的方式使用过。但是有些账户仍然可以在 CDO 消息发送中工作，有些则不能。哪些有效，哪些无效似乎是随机的，而且越来越不有效。
除了不能解决我的问题的自动问答，或者浪费时间拨打求助热线，我无法从电子邮件提供商那里找到任何帮助
任何人都可以推荐电子邮件帐户提供商，他们发现其帐户在 CDO 消息宏中始终有效。
我想我知道大部分必需的设置，因为我之前已经能够让帐户正常工作。我猜垃圾邮件软件可能正在收紧，作为副产品，真正的使用更经常被错误地阻止……我猜自动使用帐户更有可能引起怀疑。
gmail 对我来说一直非常可靠。但现在 10 个帐户中有 7 个无法使用。我不能再注册了，因为他们限制你每个确认电话号码只能注册几次。所以我预计很快 gmail 将不再是我的选择。
yahoo 和 yandex 上的新帐户通常可以运行几次然后停止运行。偶尔他们偶尔会再次工作。
我目前唯一一直在工作的供应商是一家小型德国电信供应商。但是根据 Sod 定律，我需要的一些电子邮件功能在大多数其他供应商上都可用，但在这个德国供应商上却没有！ :--(
我可以在不同的位置使用几台不同的计算机和互联网连接。我在不同的地方得到类似的结果。所以我不认为这是与我的互联网连接有关的间歇性问题。我的意思是，当前持续运行的帐户将在具有不同质量互联网连接的不同地方运行。
我的猜测是问题出在自动安全措施上，不同的供应商会有所不同，所以这就是为什么我询问其他人使用电子邮件帐户和 CDO 消息发送编码的经验。
在所有情况下，在 CDO 编码中停止工作的帐户仍然可以手动工作。我知道当从新位置使用帐户时，经常会出现临时封锁。这只会导致临时阻塞。这不是我的问题。这些临时块也发生在工作帐户上，我知道如何处理它们。
谢谢
艾伦
为我的最后一个答案编码 ()
编辑：答案 post 已被隐藏！ - 这是它的副本：http://www.excelfox.com/forum/showthread.php/2380-Tests-and-Notes-for-EMail-Threads?p=11548&viewfull=1#post11548
Option Explicit
''_-(ii) "sendusername" , "sendpassword" , "smtpusessl" , "smtpauthenticate" , "smtpserver" , "sendusing" , "smtpserverport" , "smtpconnectiontimeout"
'Sub ScrudOverFlowDemolition(ByVal UsrNme As String, ByVal PssWrd As String, ByVal SlutPussly As String, ByVal PatheticCake As String, ByVal ServiceChef As String, ByVal WayntkerUsed As String, ByVal ConnectingDoor As String, ByVal WaitSecs As String, ByVal Snd_Frm As String)
Dim CunFik() As String ' CDO Account configuration
Dim CunFikaNation As String ' CDO Account configurations, CunFik(x)s seperated by vbCr & vbLf is "sendusername" "sendpassword" "smtpusessl" "smtpauthenticate" "smtpserver" "sendusing" "smtpserverport" "smtpconnectiontimeout"
'_- Program_(i)
' ( '_-(ii) ScrudOverFlow..("sendusername","sendpassword","smtpusessl","smtpauthenticate","smtpserver","sendusing","smtpserverport","smtpconnectiontimeout", .From )
Sub TestCall_ScrudOverFlowDemolition()
Let CunFikaNation = ""
Rem 1 Collect of accounts and their configuration parameters
' gmail
Call ScrudOverFlowDemolition("1234567890123456789.com", "xxxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "ExcelVBAExp@gmail.com")
Call ScrudOverFlowDemolition("1234567890@gmail.com", "xxxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "mail2taste@gmail.com")
Call ScrudOverFlowDemolition("1234567890@gmail.com", "xxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "25", "30", "mail2taste@gmail.com")
Call ScrudOverFlowDemolition("1234567890123456@gmail.com", "xxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "excellearning12@gmail.com")
Call ScrudOverFlowDemolition("12345678901@gmail.com", "xxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "JaneAmbrose1958@gmail.com")
Call ScrudOverFlowDemolition("1234567890@gmail.com", "xxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "CDOMsgExp@gmail.com")
Call ScrudOverFlowDemolition("123456789@gmail.com", "xxxxxxx", "True", "1", "smtp.gmail.com", "2", "25", "30", "CDOMsgExp@gmail.com")
' Yandex
Call ScrudOverFlowDemolition("xxxxxxxxxxx@yandex.com", "xxxxxxxxx", "True", "1", "smtp.yandex.com", "2", "465", "30", "developmentstest@yandex.com")
Call ScrudOverFlowDemolition("eeeeeeeeeee@yandex.com", "ahetkdkjhddhj", "True", "1", "smtp.yandex.com", "2", "465", "30", "developmentstest@yandex.com")
Call ScrudOverFlowDemolition("123456789@yandex.com", "96lskKFHSHFDLHF", "True", "1", "smtp.yandex.com", "2", "465", "30", "123456789@yandex.com")
' Yahoo
Call ScrudOverFlowDemolition("1234567890@yahoo.com", "XXXXXXXX", "True", "1", "smtp.mail.yahoo.com", "2", "465", "30", "yangsfool@yahoo.com")
' Outlook
Call ScrudOverFlowDemolition("12345678901@Outlook.com", "cccccccccc*", "True", "1", "smtp-mail.outlook.com", "2", "587", "30", "MollyBrennholz@Outlook.com")
Call ScrudOverFlowDemolition("123456789012@Outlook.com", "yyyyyyyy", "True", "1", "smtp-mail.outlook.com", "2", "587", "30", "excellearning@Outlook.com")
'Call ScrudOverFlowDemolition("123456789012@Outlook.com", "zzzzzzzzzz", "True", "1", "smtp-mail.outlook.com", "2", "465", "30", "excellearning@Outlook.com") ' This line takes a long time
' GMX
Call ScrudOverFlowDemolition("1234567890@gmx.net", "fffffffffffff", "True", "1", "mail.gmx.net", "2", "465", "30", "GiMiCDOMsg@gmx.net")
Call ScrudOverFlowDemolition("12345678901234@gmx.net", "xxxxxx", "True", "1", "mail.gmx.net", "2", "465", "30", "Doc.AElstein@gmx.net")
Call ScrudOverFlowDemolition("12345@gmx.com", "966455535", "True", "1", "mail.gmx.com", "2", "465", "30", "Vixer@gmx.com")
' AOL
Call ScrudOverFlowDemolition("123456789@aol.com", "dddddddddd", "True", "1", "smtp.aol.com", "2", "587", "30", "aliarseol@aol.com")
' German Telekom
Call ScrudOverFlowDemolition("12345@t-online.de", "cccccccccc", "True", "1", "securesmtp.t-online.de", "2", "465", "30", "Jayae@t-online.de")
Call ScrudOverFlowDemolition("12345678901@t-online.de", "ddddddddddd", "True", "1", "securesmtp.t-online.de", "2", "465", "30", "CDOMsgTest@t-online.de")
Call ScrudOverFlowDemolition("12345678901234@t-online.de", "eeeeeeeeeeee", "True", "1", "securesmtp.t-online.de", "2", "465", "30", "CDOMsgScrotum@t-online.de")
'
If CunFikaNation <> "" Then Let CunFikaNation = Left(CunFikaNation, Len(CunFikaNation) - 2) ' I do not need the last vbCr & vbLf
Rem 2 Store the final string Configuration parameters
' 2a) In the Immediate window
Debug.Print CunFikaNation
' 2b) Send CunFikaNation to a text file, ( the file will be made if it does not exist, or it will be overwritten if it does exist
Dim Highway2 As Long: Let Highway2 = FreeFile(0) '
Open ThisWorkbook.Path & "\" & "CunFikaNation " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Output As #Highway2 ' Text file will be made if not there
Print #Highway2, CunFikaNation
Close Highway2
' 2c) Using a function to get the string in a form which can be hardcoded into a VBA macro
' 2c)(i) direct use of CunFikaNation in function
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(CunFikaNation) ' http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016
' 2c)(ii) indirect use ater retreiving from the text file
Open ThisWorkbook.Path & "\" & "CunFikaNation " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Binary As #Highway2
Let CunFikaNation = Space$(LOF(Highway2)) ' sets buffer to Length Of File : Space$(LOF(1)) creates a string the size of the file. LOF and Space$ is to initialize the string to a given length
Get #Highway2, , CunFikaNation ' fits exactly
Close Highway2
Let CunFikaNation = Left(CunFikaNation, Len(CunFikaNation) - 2) ' There appears to be an extra 2 characters, vbCr & vbLf , added to the string which we don't want so we effectiuvely chop off the last two characters
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(CunFikaNation) ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11818&viewfull=1#post11818 http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016
' 2c)(iii) Paste to a cell
Let ThisWorkbook.Worksheets.Item(1).Range("A1").Value = CunFikaNation
End Sub
'
'
' ' Allow access to deep down cods wollops from Microsoft to collaborating in particular in the form of messaging. An available library of ddl library functions and associated things is available on request, the Microsoft CDO for Windows 2000. We require some of these ' CDO is an object library that exposes the interfaces of the Messaging Application Programming Interface (MAPI). API: interfaces that are fairly easy to use from a fairly higher level from within a higher level programming language. In other words this allows you to get at and use some of the stuff to do with the COM OLE Bollocks from within a programming language such as VBA API is often referring loosely to do with using certain shipped with Windows software in Folders often having the extension dll. This extension , or rather the dll stands for direct link libraries. These are special sort of executable files of functions shared by many other (Windows based usually) sof
'_- Program_(ii) "sendusername" , "sendpassword" , "smtpusessl" , "smtpauthenticate" , "smtpserver" , "sendusing" , "smtpserverport" , "smtpconnectiontimeout"
Sub ScrudOverFlowDemolition(ByVal UsrNme As String, ByVal PssWrd As String, ByVal SlutPussly As String, ByVal PatheticCake As String, ByVal ServiceChef As String, ByVal WayntkerUsed As String, ByVal ConnectingDoor As String, ByVal WaitSecs As String, ByVal Snd_Frm As String)
'Rem1 The deep down fundamental stuff , which includes stuff been there the longest goes by the name of Component Object Model. Stuff which is often, but not always, later stuff, or at a slightly higher level of the computer workings, or slightly more to a specific application ( an actual running "runtime" usage / at an instance in time , "instance of" ) orientated goes to the name of Object Linking and Embedding. At this lower level, there are protocols for communicating between things, and things relate are grouped into the to Office application available Library, CDO. An important object there goes by the name of Message.
'Rem 1) Library made available ====================#
With CreateObject("CDO.Message") ' Folders mostly but not always are in some way referenced using dll, either as noted with the extension or maybe refered to as dll Files or dll API files.
'Rem 2 ' Intraction protocols are given requird infomation and then set
'2a) 'With --------------------* my Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups) which are used and items configured for the Exchange at Microsoft’s protocol thereof; http://schemas.microsoft.com/cdo/configuration/ ......This section provides the configuration information for the remote SMTP server
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/" ' Linking Configuration Data : defines the majority of fields used to set configurations for various Linking Collaboration (LCD) Objects Cods Wollops: These configuration fields are set using an implementation of the IConfiguration.Fields collection. https://msdn.microsoft.com/en-us/library/ms872853(v=exchg.65).aspx
.Configuration(LCD_CW & "smtpusessl") = SlutPussly ' ' ' HTTPS (Hyper Text Transfer Protocol Secure) appears in the URL when a website is secured by an SSL certificate. The details of the certificate, including the issuing authority and the corporate name of the website owner, can be viewed by clicking on the lock symbol on the browser bar. in short, it's the standard technology for keeping an internet connection secure and safeguarding any sensitive data that is being sent between two systems, preventing criminals from reading and modifying any information transferred, including potential personal details. ' SSL protocol has always been used to encrypt and secure transmitted data
.Configuration(LCD_CW & "smtpauthenticate") = PatheticCake ' ... possibly this also needed .. When you also get the Authentication Required Error you can add this three lines.
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = ServiceChef ' "smtp.gmail.com" ' "securesmtp.t-online.de" '"smtp.gmail.com" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de" 465 SMTP is just used to mean the common stuff..... Simple Mail Transport Protocol (SMTP) server is used to send outgoing e-mails. The SMTP server receives emails from your Mail program and sends them over the Internet to their destination.
' The mechanism to use to send messages.
.Configuration(LCD_CW & "sendusing") = WayntkerUsed ' Based on the LCD_OLE Data Base of type DBTYPE_I4 , 2 will use the default account
.Configuration(LCD_CW & "smtpserverport") = ConnectingDoor ' 465 or 25 for t-online.de ' 465 'or 587 'or 25 ' The port of type somehow refered to by the last line
.Configuration(LCD_CW & "sendusername") = UsrNme ' .... "server rejected your response". AFAIK : This will happen if you haven't setup an account in Outlook Express or Windows Mail .... Runtime error '-2147220975 (800440211)': The message could not be sent to the SMTP server. The transport error code is 0x80040217. The server response is not available
.Configuration(LCD_CW & "sendpassword") = PssWrd
' Optional - How long to try ( End remote SMTP server configuration section )
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 ' Or there Abouts ;) :)
' Intraction protocol is Set/ Updated
.Configuration.fields.Update ' 'Not all infomation is given, some will have defaults. - possibly this might be needed initially .. .Configuration.Load -1 ' CDO Source Defaults
'End With ' -------------------* my Created LCDCW Library ( Linking Configuration Data Cods Wollups) which are used and items configured for the Exchange at Microsoft's protocol therof;
'2b) ' Data to be sent
.To = "123456789012@t-online.de"
.CC = "" ' 12345678901@gmail.com"
.BCC = ""
.From = Snd_Frm '
.Subject = "Hello from " & UsrNme & "" '
.TextBody = "Hi" & vbCr & vbLf & "Testing automated EMail sending. Please ignoor this EMail"
' add header for this Account in log text file.
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Open ThisWorkbook.Path & "\" & "ScrudOverFlowDemolition " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "EMail Address:""" & UsrNme & """" & vbCrLf
Close #Highway1
'Rem 3 Attemt the send
On Error GoTo Bed ' Intended to catch a possible predicted error in the next line when running the routine
.send
On Error GoTo 0
' Add to the log a note to the effect that this account was successful
Debug.Print "Done " & """" & UsrNme & """"
Open ThisWorkbook.Path & "\" & "ScrudOverFlowDemolition " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Sended " & Format(Now(), "hh mm") & " " & vbCr & vbLf
Close #Highway1
'
' Add to the string of succesful accounts CDO config data, CunFikaNation
Let CunFikaNation = CunFikaNation & UsrNme & " " & PssWrd & " " & SlutPussly & " " & PatheticCake & " " & ServiceChef & " " & WayntkerUsed & " " & ConnectingDoor & " " & WaitSecs & " " & Snd_Frm & vbCr & vbLf
End With ' CreateObject("CDO.Message") (Rem 1 Library End =======#
Exit Sub ' Normal routine end for no error exceptional errected situation
Bed: ' Intended to catch an error when running the routine
' Add to the log a note to the effrect that this account was unsuccessful
Debug.Print "Not done " & """" & UsrNme & """" & " Error is " & Err.Number & ": " & Err.Description
Open ThisWorkbook.Path & "\" & "ScrudOverFlowDemolition " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Fail " & Format(Now(), "hh mm") & " " & Err.Number & ": " & Err.Description & vbLf
Close #Highway1
' On Error GoTo -1: On Error GoTo 0 ' Do not need to do this as the code is ending
End Sub
' NOTE: This is an extra macro that can be used to fill the global variable, CunFikaNation . This can be useful in development since the global variable is often emptied. It is also useful for checking error handling in the next coding, since you can modify the text file, then refil the global variable , CunFikaNation from it
Sub GetthelastCunFikaNation()
Dim Highway2 As Long: Let Highway2 = FreeFile(0) 'range 1 – 255, inclusive - next free The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Open ThisWorkbook.Path & "\" & "CunFikaNation " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Binary As #Highway2
Let CunFikaNation = Space$(LOF(Highway2)) ' sets buffer to Length Of File : Space$(LOF(1)) creates a string the size of the file. LOF and Space$ is to initialize the string to a given length
Get #Highway2, , CunFikaNation ' fits exactly
Close Highway2
Let CunFikaNation = Left(CunFikaNation, Len(CunFikaNation) - 2) ' There appears to be an extra 2 characters, vbCr & vbLf , added to the string which we don't want so we effectiuvely chop off the last two characters
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(CunFikaNation) ' http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016
' 2c)(iii) Paste to a cell
' Let ThisWorkbook.Worksheets.Item(1).Range("A1").Value = CunFikaNation ' This is already done by Call WtchaGot_Unic_NotMuchIfYaChoppedItOff( )
End Sub
' '_- Program_(iii)
Sub CallCDOSendMailAttempt()
Dim VlagaMir As Boolean ' This is set to True after an EMail is succcesful
Rem 1 make array for the configutration parameters of all EMail accounts
Dim SptACnt() As String: Let SptACnt() = Split(CunFikaNation, vbCr & vbLf, -1, vbBinaryCompare)
Rem 2 pass the config parameters to CDOSendMail until successful mail send
Dim Cnt As Long
For Cnt = 0 To UBound(SptACnt())
Dim CunFik() As String: Let CunFik() = Split(SptACnt(Cnt), " ", 9, vbBinaryCompare)
Call CDOSendMailAttempt(VlagaMir, CunFik(0), CunFik(1), CunFik(2), CunFik(3), CunFik(4), CunFik(5), CunFik(6), CunFik(7), CunFik(8))
If VlagaMir = True Then Exit Sub
Next Cnt
End Sub
' '_- Program_(iv)
Sub CDOSendMailAttempt(ByRef FlagerMe As Boolean, ByVal UsrNme As String, ByVal PssWrd As String, ByVal SlutPussly As String, ByVal PatheticCake As String, ByVal ServiceChef As String, ByVal WayntkerUsed As String, ByVal ConnectingDoor As String, ByVal WaitSecs As String, ByVal Snd_Frm As String)
'Rem1 The deep down fundamental stuff , ...
'Rem 1) Library made available ====================#
With CreateObject("CDO.Message") ' Folders mostly but not always are in some way referenced using dll, either as noted with the extension or maybe refered to as dll Files or dll API files.
'Rem 2 ' Intraction protocols are given requird infomation and then set
'2a) 'With --------------------* my Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups) which are used and items configured for the Exchange at Microsoft’s protocol thereof; http://schemas.microsoft.com/cdo/configuration/ ......This section provides the configuration information for the remote SMTP server
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/" ' Linking Configuration Data : defines the majority of fields used to set configurations for various Linking Collaboration (LCD) Objects Cods Wollops: These configuration fields are set using an implementation of the IConfiguration.Fields collection. https://msdn.microsoft.com/en-us/library/ms872853(v=exchg.65).aspx
.Configuration(LCD_CW & "smtpusessl") = SlutPussly ' ' ' HTTPS (Hyper Text Transfer Protocol Secure) appears in the URL when a website is secured by an SSL certificate. The details of the certificate, including the issuing authority and the corporate name of the website owner, can be viewed by clicking on the lock symbol on the browser bar. in short, it's the standard technology for keeping an internet connection secure and safeguarding any sensitive data that is being sent between two systems, preventing criminals from reading and modifying any information transferred, including potential personal details. ' SSL protocol has always been used to encrypt and secure transmitted data
.Configuration(LCD_CW & "smtpauthenticate") = PatheticCake ' ... possibly this also needed .. When you also get the Authentication Required Error you can add this three lines.
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = ServiceChef ' "smtp.gmail.com" ' "securesmtp.t-online.de" '"smtp.gmail.com" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de" 465 SMTP is just used to mean the common stuff..... Simple Mail Transport Protocol (SMTP) server is used to send outgoing e-mails. The SMTP server receives emails from your Mail program and sends them over the Internet to their destination.
' The mechanism to use to send messages.
.Configuration(LCD_CW & "sendusing") = WayntkerUsed ' Based on the LCD_OLE Data Base of type DBTYPE_I4 , 2 will use the default account
.Configuration(LCD_CW & "smtpserverport") = ConnectingDoor ' 465 or 25 for t-online.de ' 465 'or 587 'or 25 ' The port of type somehow refered to by the last line
.Configuration(LCD_CW & "sendusername") = UsrNme ' .... "server rejected your response". AFAIK : This will happen if you haven't setup an account in Outlook Express or Windows Mail .... Runtime error '-2147220975 (800440211)': The message could not be sent to the SMTP server. The transport error code is 0x80040217. The server response is not available
.Configuration(LCD_CW & "sendpassword") = PssWrd
' Optional - How long to try ( End remote SMTP server configuration section )
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 ' Or there Abouts ;) :)
' Intraction protocol is Set/ Updated
.Configuration.fields.Update ' 'Not all infomation is given, some will have defaults. - possibly this might be needed initially .. .Configuration.Load -1 ' CDO Source Defaults
'End With ' -------------------* my Created LCDCW Library ( Linking Configuration Data Cods Wollups) which are used and items configured for the Exchange at Microsoft's protocol therof;
'2b) ' Data to be sent
.To = "1234567890123@t-online.de"
.CC = "" ' 1234567890@gmail.com"
.BCC = ""
.From = Snd_Frm ' """Avinash_gMail_Send"" <" & UsrNme & ">"
.Subject = "Hello from " & UsrNme & "" ' "Pro für " & DieseArbeitsmappe1.LisWbProWb.Name
.TextBody = "Hi" & vbCr & vbLf & "Testing automated EMail sending. Please ignoor this EMail"
'.HTMLBody = MyLengthyStreaming
'.htmlbody = ProTble
' Add text file attachments
' make file if it does not exist, or add to it
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Open ThisWorkbook.Path & "\" & "CDOSendMailAttempt " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "EMail Address:""" & UsrNme & """" & vbCrLf
Close #Highway1
'Dim DirTxtFl As String: Let DirTxtFl = Dir(ThisWorkbook.Path & "\" & "*.txt")
' Do While DirTxtFl <> ""
' If VBA.Left$(DirTxtFl, 7) = "Avinash" Then .AddAttachment ThisWorkbook.Path & "\" & DirTxtFl
' Let DirTxtFl = Dir
' Loop
'Rem 3 Do it
On Error GoTo Bed ' Intended to catch a possible predicted error in the next line when running the routine
.send
On Error GoTo 0
' MsgBox Prompt:="Done " & """" & UsrNme & """" & "(with " & SmptySvrPrt & ")" ' This will typically give either "Done (with 25)" or "Done (with 465)" if the routine worked
Debug.Print "Done " & """" & UsrNme & """"
Open ThisWorkbook.Path & "\" & "CDOSendMailAttempt " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Sended " & Format(Now(), "hh mm") & " " & vbCr & vbLf
Close #Highway1
End With ' CreateObject("CDO.Message") (Rem 1 Library End =======#
Let FlagerMe = True ' Boolean set to True after a succesful run of macro
Exit Sub ' Normal succesful run of macro end
Bed:
Debug.Print "Not done " & """" & UsrNme & """" & " Error is " & Err.Number & ": " & Err.Description
Open ThisWorkbook.Path & "\" & "CDOSendMailAttempt " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Fail " & Format(Now(), "hh mm") & " " & Err.Number & ": " & Err.Description & vbLf
Close #Highway1
' ' On Error GoTo -1 ' This takes out of the exceptional error handling state, so that the Error handler will work again ... not needed as the sub ends
' Ending Sub with FagerMe still set at False
End Sub
你好
我一直在尝试使用一些 CDO 消息 VBA 编码来自动发送简短的电子邮件。全部供私人使用，每天最多发送几封电子邮件。电子邮件要么是给我家人的，要么是我与之共享编码的其他人，例如在免费帮助论坛上。 我的宏确实有效，而且在过去非常可靠。 最近我发现越来越多的电子邮件帐户不再有效。所以我必须用另一个替换发送电子邮件帐户。 我 运行 没有可用的帐户。 新帐户要么不起作用，要么只工作几次，然后在进一步尝试时会出现各种错误。 我使用的来自同一提供商的不同帐户都具有相同的设置，并且在某些情况下以前以类似的方式使用过。但是有些账户仍然可以在 CDO 消息发送中工作，有些则不能。哪些有效，哪些无效似乎是随机的，而且越来越不有效。
除了不能解决我的问题的自动问答，或者浪费时间拨打求助热线，我无法从电子邮件提供商那里找到任何帮助
任何人都可以推荐电子邮件帐户提供商，他们发现其帐户在 CDO 消息宏中始终有效。
我想我知道大部分必需的设置，因为我之前已经能够让帐户正常工作。我猜垃圾邮件软件可能正在收紧，作为副产品，真正的使用更经常被错误地阻止……我猜自动使用帐户更有可能引起怀疑。
gmail 对我来说一直非常可靠。但现在 10 个帐户中有 7 个无法使用。我不能再注册了，因为他们限制你每个确认电话号码只能注册几次。所以我预计很快 gmail 将不再是我的选择。
yahoo 和 yandex 上的新帐户通常可以运行几次然后停止运行。偶尔他们偶尔会再次工作。
我目前唯一一直在工作的供应商是一家小型德国电信供应商。但是根据 Sod 定律，我需要的一些电子邮件功能在大多数其他供应商上都可用，但在这个德国供应商上却没有！ :--(
我可以在不同的位置使用几台不同的计算机和互联网连接。我在不同的地方得到类似的结果。所以我不认为这是与我的互联网连接有关的间歇性问题。我的意思是，当前持续运行的帐户将在具有不同质量互联网连接的不同地方运行。
我的猜测是问题出在自动安全措施上，不同的供应商会有所不同，所以这就是为什么我询问其他人使用电子邮件帐户和 CDO 消息发送编码的经验。
在所有情况下，在 CDO 编码中停止工作的帐户仍然可以手动工作。我知道当从新位置使用帐户时，经常会出现临时封锁。这只会导致临时阻塞。这不是我的问题。这些临时块也发生在工作帐户上，我知道如何处理它们。
谢谢 艾伦
为我的最后一个答案编码 (
编辑：答案 post 已被隐藏！ - 这是它的副本：http://www.excelfox.com/forum/showthread.php/2380-Tests-and-Notes-for-EMail-Threads?p=11548&viewfull=1#post11548
Option Explicit
''_-(ii) "sendusername" , "sendpassword" , "smtpusessl" , "smtpauthenticate" , "smtpserver" , "sendusing" , "smtpserverport" , "smtpconnectiontimeout"
'Sub ScrudOverFlowDemolition(ByVal UsrNme As String, ByVal PssWrd As String, ByVal SlutPussly As String, ByVal PatheticCake As String, ByVal ServiceChef As String, ByVal WayntkerUsed As String, ByVal ConnectingDoor As String, ByVal WaitSecs As String, ByVal Snd_Frm As String)
Dim CunFik() As String ' CDO Account configuration
Dim CunFikaNation As String ' CDO Account configurations, CunFik(x)s seperated by vbCr & vbLf is "sendusername" "sendpassword" "smtpusessl" "smtpauthenticate" "smtpserver" "sendusing" "smtpserverport" "smtpconnectiontimeout"
'_- Program_(i)
' ( '_-(ii) ScrudOverFlow..("sendusername","sendpassword","smtpusessl","smtpauthenticate","smtpserver","sendusing","smtpserverport","smtpconnectiontimeout", .From )
Sub TestCall_ScrudOverFlowDemolition()
Let CunFikaNation = ""
Rem 1 Collect of accounts and their configuration parameters
' gmail
Call ScrudOverFlowDemolition("1234567890123456789.com", "xxxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "ExcelVBAExp@gmail.com")
Call ScrudOverFlowDemolition("1234567890@gmail.com", "xxxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "mail2taste@gmail.com")
Call ScrudOverFlowDemolition("1234567890@gmail.com", "xxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "25", "30", "mail2taste@gmail.com")
Call ScrudOverFlowDemolition("1234567890123456@gmail.com", "xxxxxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "excellearning12@gmail.com")
Call ScrudOverFlowDemolition("12345678901@gmail.com", "xxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "JaneAmbrose1958@gmail.com")
Call ScrudOverFlowDemolition("1234567890@gmail.com", "xxxxxxx", "True", "1", "smtp.gmail.com", "2", "465", "30", "CDOMsgExp@gmail.com")
Call ScrudOverFlowDemolition("123456789@gmail.com", "xxxxxxx", "True", "1", "smtp.gmail.com", "2", "25", "30", "CDOMsgExp@gmail.com")
' Yandex
Call ScrudOverFlowDemolition("xxxxxxxxxxx@yandex.com", "xxxxxxxxx", "True", "1", "smtp.yandex.com", "2", "465", "30", "developmentstest@yandex.com")
Call ScrudOverFlowDemolition("eeeeeeeeeee@yandex.com", "ahetkdkjhddhj", "True", "1", "smtp.yandex.com", "2", "465", "30", "developmentstest@yandex.com")
Call ScrudOverFlowDemolition("123456789@yandex.com", "96lskKFHSHFDLHF", "True", "1", "smtp.yandex.com", "2", "465", "30", "123456789@yandex.com")
' Yahoo
Call ScrudOverFlowDemolition("1234567890@yahoo.com", "XXXXXXXX", "True", "1", "smtp.mail.yahoo.com", "2", "465", "30", "yangsfool@yahoo.com")
' Outlook
Call ScrudOverFlowDemolition("12345678901@Outlook.com", "cccccccccc*", "True", "1", "smtp-mail.outlook.com", "2", "587", "30", "MollyBrennholz@Outlook.com")
Call ScrudOverFlowDemolition("123456789012@Outlook.com", "yyyyyyyy", "True", "1", "smtp-mail.outlook.com", "2", "587", "30", "excellearning@Outlook.com")
'Call ScrudOverFlowDemolition("123456789012@Outlook.com", "zzzzzzzzzz", "True", "1", "smtp-mail.outlook.com", "2", "465", "30", "excellearning@Outlook.com") ' This line takes a long time
' GMX
Call ScrudOverFlowDemolition("1234567890@gmx.net", "fffffffffffff", "True", "1", "mail.gmx.net", "2", "465", "30", "GiMiCDOMsg@gmx.net")
Call ScrudOverFlowDemolition("12345678901234@gmx.net", "xxxxxx", "True", "1", "mail.gmx.net", "2", "465", "30", "Doc.AElstein@gmx.net")
Call ScrudOverFlowDemolition("12345@gmx.com", "966455535", "True", "1", "mail.gmx.com", "2", "465", "30", "Vixer@gmx.com")
' AOL
Call ScrudOverFlowDemolition("123456789@aol.com", "dddddddddd", "True", "1", "smtp.aol.com", "2", "587", "30", "aliarseol@aol.com")
' German Telekom
Call ScrudOverFlowDemolition("12345@t-online.de", "cccccccccc", "True", "1", "securesmtp.t-online.de", "2", "465", "30", "Jayae@t-online.de")
Call ScrudOverFlowDemolition("12345678901@t-online.de", "ddddddddddd", "True", "1", "securesmtp.t-online.de", "2", "465", "30", "CDOMsgTest@t-online.de")
Call ScrudOverFlowDemolition("12345678901234@t-online.de", "eeeeeeeeeeee", "True", "1", "securesmtp.t-online.de", "2", "465", "30", "CDOMsgScrotum@t-online.de")
'
If CunFikaNation <> "" Then Let CunFikaNation = Left(CunFikaNation, Len(CunFikaNation) - 2) ' I do not need the last vbCr & vbLf
Rem 2 Store the final string Configuration parameters
' 2a) In the Immediate window
Debug.Print CunFikaNation
' 2b) Send CunFikaNation to a text file, ( the file will be made if it does not exist, or it will be overwritten if it does exist
Dim Highway2 As Long: Let Highway2 = FreeFile(0) '
Open ThisWorkbook.Path & "\" & "CunFikaNation " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Output As #Highway2 ' Text file will be made if not there
Print #Highway2, CunFikaNation
Close Highway2
' 2c) Using a function to get the string in a form which can be hardcoded into a VBA macro
' 2c)(i) direct use of CunFikaNation in function
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(CunFikaNation) ' http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016
' 2c)(ii) indirect use ater retreiving from the text file
Open ThisWorkbook.Path & "\" & "CunFikaNation " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Binary As #Highway2
Let CunFikaNation = Space$(LOF(Highway2)) ' sets buffer to Length Of File : Space$(LOF(1)) creates a string the size of the file. LOF and Space$ is to initialize the string to a given length
Get #Highway2, , CunFikaNation ' fits exactly
Close Highway2
Let CunFikaNation = Left(CunFikaNation, Len(CunFikaNation) - 2) ' There appears to be an extra 2 characters, vbCr & vbLf , added to the string which we don't want so we effectiuvely chop off the last two characters
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(CunFikaNation) ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11818&viewfull=1#post11818 http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016
' 2c)(iii) Paste to a cell
Let ThisWorkbook.Worksheets.Item(1).Range("A1").Value = CunFikaNation
End Sub
'
'
' ' Allow access to deep down cods wollops from Microsoft to collaborating in particular in the form of messaging. An available library of ddl library functions and associated things is available on request, the Microsoft CDO for Windows 2000. We require some of these ' CDO is an object library that exposes the interfaces of the Messaging Application Programming Interface (MAPI). API: interfaces that are fairly easy to use from a fairly higher level from within a higher level programming language. In other words this allows you to get at and use some of the stuff to do with the COM OLE Bollocks from within a programming language such as VBA API is often referring loosely to do with using certain shipped with Windows software in Folders often having the extension dll. This extension , or rather the dll stands for direct link libraries. These are special sort of executable files of functions shared by many other (Windows based usually) sof
'_- Program_(ii) "sendusername" , "sendpassword" , "smtpusessl" , "smtpauthenticate" , "smtpserver" , "sendusing" , "smtpserverport" , "smtpconnectiontimeout"
Sub ScrudOverFlowDemolition(ByVal UsrNme As String, ByVal PssWrd As String, ByVal SlutPussly As String, ByVal PatheticCake As String, ByVal ServiceChef As String, ByVal WayntkerUsed As String, ByVal ConnectingDoor As String, ByVal WaitSecs As String, ByVal Snd_Frm As String)
'Rem1 The deep down fundamental stuff , which includes stuff been there the longest goes by the name of Component Object Model. Stuff which is often, but not always, later stuff, or at a slightly higher level of the computer workings, or slightly more to a specific application ( an actual running "runtime" usage / at an instance in time , "instance of" ) orientated goes to the name of Object Linking and Embedding. At this lower level, there are protocols for communicating between things, and things relate are grouped into the to Office application available Library, CDO. An important object there goes by the name of Message.
'Rem 1) Library made available ====================#
With CreateObject("CDO.Message") ' Folders mostly but not always are in some way referenced using dll, either as noted with the extension or maybe refered to as dll Files or dll API files.
'Rem 2 ' Intraction protocols are given requird infomation and then set
'2a) 'With --------------------* my Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups) which are used and items configured for the Exchange at Microsoft’s protocol thereof; http://schemas.microsoft.com/cdo/configuration/ ......This section provides the configuration information for the remote SMTP server
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/" ' Linking Configuration Data : defines the majority of fields used to set configurations for various Linking Collaboration (LCD) Objects Cods Wollops: These configuration fields are set using an implementation of the IConfiguration.Fields collection. https://msdn.microsoft.com/en-us/library/ms872853(v=exchg.65).aspx
.Configuration(LCD_CW & "smtpusessl") = SlutPussly ' ' ' HTTPS (Hyper Text Transfer Protocol Secure) appears in the URL when a website is secured by an SSL certificate. The details of the certificate, including the issuing authority and the corporate name of the website owner, can be viewed by clicking on the lock symbol on the browser bar. in short, it's the standard technology for keeping an internet connection secure and safeguarding any sensitive data that is being sent between two systems, preventing criminals from reading and modifying any information transferred, including potential personal details. ' SSL protocol has always been used to encrypt and secure transmitted data
.Configuration(LCD_CW & "smtpauthenticate") = PatheticCake ' ... possibly this also needed .. When you also get the Authentication Required Error you can add this three lines.
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = ServiceChef ' "smtp.gmail.com" ' "securesmtp.t-online.de" '"smtp.gmail.com" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de" 465 SMTP is just used to mean the common stuff..... Simple Mail Transport Protocol (SMTP) server is used to send outgoing e-mails. The SMTP server receives emails from your Mail program and sends them over the Internet to their destination.
' The mechanism to use to send messages.
.Configuration(LCD_CW & "sendusing") = WayntkerUsed ' Based on the LCD_OLE Data Base of type DBTYPE_I4 , 2 will use the default account
.Configuration(LCD_CW & "smtpserverport") = ConnectingDoor ' 465 or 25 for t-online.de ' 465 'or 587 'or 25 ' The port of type somehow refered to by the last line
.Configuration(LCD_CW & "sendusername") = UsrNme ' .... "server rejected your response". AFAIK : This will happen if you haven't setup an account in Outlook Express or Windows Mail .... Runtime error '-2147220975 (800440211)': The message could not be sent to the SMTP server. The transport error code is 0x80040217. The server response is not available
.Configuration(LCD_CW & "sendpassword") = PssWrd
' Optional - How long to try ( End remote SMTP server configuration section )
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 ' Or there Abouts ;) :)
' Intraction protocol is Set/ Updated
.Configuration.fields.Update ' 'Not all infomation is given, some will have defaults. - possibly this might be needed initially .. .Configuration.Load -1 ' CDO Source Defaults
'End With ' -------------------* my Created LCDCW Library ( Linking Configuration Data Cods Wollups) which are used and items configured for the Exchange at Microsoft's protocol therof;
'2b) ' Data to be sent
.To = "123456789012@t-online.de"
.CC = "" ' 12345678901@gmail.com"
.BCC = ""
.From = Snd_Frm '
.Subject = "Hello from " & UsrNme & "" '
.TextBody = "Hi" & vbCr & vbLf & "Testing automated EMail sending. Please ignoor this EMail"
' add header for this Account in log text file.
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Open ThisWorkbook.Path & "\" & "ScrudOverFlowDemolition " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "EMail Address:""" & UsrNme & """" & vbCrLf
Close #Highway1
'Rem 3 Attemt the send
On Error GoTo Bed ' Intended to catch a possible predicted error in the next line when running the routine
.send
On Error GoTo 0
' Add to the log a note to the effect that this account was successful
Debug.Print "Done " & """" & UsrNme & """"
Open ThisWorkbook.Path & "\" & "ScrudOverFlowDemolition " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Sended " & Format(Now(), "hh mm") & " " & vbCr & vbLf
Close #Highway1
'
' Add to the string of succesful accounts CDO config data, CunFikaNation
Let CunFikaNation = CunFikaNation & UsrNme & " " & PssWrd & " " & SlutPussly & " " & PatheticCake & " " & ServiceChef & " " & WayntkerUsed & " " & ConnectingDoor & " " & WaitSecs & " " & Snd_Frm & vbCr & vbLf
End With ' CreateObject("CDO.Message") (Rem 1 Library End =======#
Exit Sub ' Normal routine end for no error exceptional errected situation
Bed: ' Intended to catch an error when running the routine
' Add to the log a note to the effrect that this account was unsuccessful
Debug.Print "Not done " & """" & UsrNme & """" & " Error is " & Err.Number & ": " & Err.Description
Open ThisWorkbook.Path & "\" & "ScrudOverFlowDemolition " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Fail " & Format(Now(), "hh mm") & " " & Err.Number & ": " & Err.Description & vbLf
Close #Highway1
' On Error GoTo -1: On Error GoTo 0 ' Do not need to do this as the code is ending
End Sub
' NOTE: This is an extra macro that can be used to fill the global variable, CunFikaNation . This can be useful in development since the global variable is often emptied. It is also useful for checking error handling in the next coding, since you can modify the text file, then refil the global variable , CunFikaNation from it
Sub GetthelastCunFikaNation()
Dim Highway2 As Long: Let Highway2 = FreeFile(0) 'range 1 – 255, inclusive - next free The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Open ThisWorkbook.Path & "\" & "CunFikaNation " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Binary As #Highway2
Let CunFikaNation = Space$(LOF(Highway2)) ' sets buffer to Length Of File : Space$(LOF(1)) creates a string the size of the file. LOF and Space$ is to initialize the string to a given length
Get #Highway2, , CunFikaNation ' fits exactly
Close Highway2
Let CunFikaNation = Left(CunFikaNation, Len(CunFikaNation) - 2) ' There appears to be an extra 2 characters, vbCr & vbLf , added to the string which we don't want so we effectiuvely chop off the last two characters
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(CunFikaNation) ' http://www.excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11016&viewfull=1#post11016
' 2c)(iii) Paste to a cell
' Let ThisWorkbook.Worksheets.Item(1).Range("A1").Value = CunFikaNation ' This is already done by Call WtchaGot_Unic_NotMuchIfYaChoppedItOff( )
End Sub
' '_- Program_(iii)
Sub CallCDOSendMailAttempt()
Dim VlagaMir As Boolean ' This is set to True after an EMail is succcesful
Rem 1 make array for the configutration parameters of all EMail accounts
Dim SptACnt() As String: Let SptACnt() = Split(CunFikaNation, vbCr & vbLf, -1, vbBinaryCompare)
Rem 2 pass the config parameters to CDOSendMail until successful mail send
Dim Cnt As Long
For Cnt = 0 To UBound(SptACnt())
Dim CunFik() As String: Let CunFik() = Split(SptACnt(Cnt), " ", 9, vbBinaryCompare)
Call CDOSendMailAttempt(VlagaMir, CunFik(0), CunFik(1), CunFik(2), CunFik(3), CunFik(4), CunFik(5), CunFik(6), CunFik(7), CunFik(8))
If VlagaMir = True Then Exit Sub
Next Cnt
End Sub
' '_- Program_(iv)
Sub CDOSendMailAttempt(ByRef FlagerMe As Boolean, ByVal UsrNme As String, ByVal PssWrd As String, ByVal SlutPussly As String, ByVal PatheticCake As String, ByVal ServiceChef As String, ByVal WayntkerUsed As String, ByVal ConnectingDoor As String, ByVal WaitSecs As String, ByVal Snd_Frm As String)
'Rem1 The deep down fundamental stuff , ...
'Rem 1) Library made available ====================#
With CreateObject("CDO.Message") ' Folders mostly but not always are in some way referenced using dll, either as noted with the extension or maybe refered to as dll Files or dll API files.
'Rem 2 ' Intraction protocols are given requird infomation and then set
'2a) 'With --------------------* my Created LCDCW Library, (LCD 1.0 Library ) (Linking Configuration Data_Cods Wollups) which are used and items configured for the Exchange at Microsoft’s protocol thereof; http://schemas.microsoft.com/cdo/configuration/ ......This section provides the configuration information for the remote SMTP server
Dim LCD_CW As String: Let LCD_CW = "http://schemas.microsoft.com/cdo/configuration/" ' Linking Configuration Data : defines the majority of fields used to set configurations for various Linking Collaboration (LCD) Objects Cods Wollops: These configuration fields are set using an implementation of the IConfiguration.Fields collection. https://msdn.microsoft.com/en-us/library/ms872853(v=exchg.65).aspx
.Configuration(LCD_CW & "smtpusessl") = SlutPussly ' ' ' HTTPS (Hyper Text Transfer Protocol Secure) appears in the URL when a website is secured by an SSL certificate. The details of the certificate, including the issuing authority and the corporate name of the website owner, can be viewed by clicking on the lock symbol on the browser bar. in short, it's the standard technology for keeping an internet connection secure and safeguarding any sensitive data that is being sent between two systems, preventing criminals from reading and modifying any information transferred, including potential personal details. ' SSL protocol has always been used to encrypt and secure transmitted data
.Configuration(LCD_CW & "smtpauthenticate") = PatheticCake ' ... possibly this also needed .. When you also get the Authentication Required Error you can add this three lines.
' ' Sever info
.Configuration(LCD_CW & "smtpserver") = ServiceChef ' "smtp.gmail.com" ' "securesmtp.t-online.de" '"smtp.gmail.com" "smtp.mail.yahoo.com" "smtp.live.com" "pod51017.outlook.com" "smtp-mail.outlook.com" "smtp.live.com" "securesmtp.t-online.de" 465 SMTP is just used to mean the common stuff..... Simple Mail Transport Protocol (SMTP) server is used to send outgoing e-mails. The SMTP server receives emails from your Mail program and sends them over the Internet to their destination.
' The mechanism to use to send messages.
.Configuration(LCD_CW & "sendusing") = WayntkerUsed ' Based on the LCD_OLE Data Base of type DBTYPE_I4 , 2 will use the default account
.Configuration(LCD_CW & "smtpserverport") = ConnectingDoor ' 465 or 25 for t-online.de ' 465 'or 587 'or 25 ' The port of type somehow refered to by the last line
.Configuration(LCD_CW & "sendusername") = UsrNme ' .... "server rejected your response". AFAIK : This will happen if you haven't setup an account in Outlook Express or Windows Mail .... Runtime error '-2147220975 (800440211)': The message could not be sent to the SMTP server. The transport error code is 0x80040217. The server response is not available
.Configuration(LCD_CW & "sendpassword") = PssWrd
' Optional - How long to try ( End remote SMTP server configuration section )
.Configuration(LCD_CW & "smtpconnectiontimeout") = 30 ' Or there Abouts ;) :)
' Intraction protocol is Set/ Updated
.Configuration.fields.Update ' 'Not all infomation is given, some will have defaults. - possibly this might be needed initially .. .Configuration.Load -1 ' CDO Source Defaults
'End With ' -------------------* my Created LCDCW Library ( Linking Configuration Data Cods Wollups) which are used and items configured for the Exchange at Microsoft's protocol therof;
'2b) ' Data to be sent
.To = "1234567890123@t-online.de"
.CC = "" ' 1234567890@gmail.com"
.BCC = ""
.From = Snd_Frm ' """Avinash_gMail_Send"" <" & UsrNme & ">"
.Subject = "Hello from " & UsrNme & "" ' "Pro für " & DieseArbeitsmappe1.LisWbProWb.Name
.TextBody = "Hi" & vbCr & vbLf & "Testing automated EMail sending. Please ignoor this EMail"
'.HTMLBody = MyLengthyStreaming
'.htmlbody = ProTble
' Add text file attachments
' make file if it does not exist, or add to it
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use. The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511. https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
Open ThisWorkbook.Path & "\" & "CDOSendMailAttempt " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "EMail Address:""" & UsrNme & """" & vbCrLf
Close #Highway1
'Dim DirTxtFl As String: Let DirTxtFl = Dir(ThisWorkbook.Path & "\" & "*.txt")
' Do While DirTxtFl <> ""
' If VBA.Left$(DirTxtFl, 7) = "Avinash" Then .AddAttachment ThisWorkbook.Path & "\" & DirTxtFl
' Let DirTxtFl = Dir
' Loop
'Rem 3 Do it
On Error GoTo Bed ' Intended to catch a possible predicted error in the next line when running the routine
.send
On Error GoTo 0
' MsgBox Prompt:="Done " & """" & UsrNme & """" & "(with " & SmptySvrPrt & ")" ' This will typically give either "Done (with 25)" or "Done (with 465)" if the routine worked
Debug.Print "Done " & """" & UsrNme & """"
Open ThisWorkbook.Path & "\" & "CDOSendMailAttempt " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Sended " & Format(Now(), "hh mm") & " " & vbCr & vbLf
Close #Highway1
End With ' CreateObject("CDO.Message") (Rem 1 Library End =======#
Let FlagerMe = True ' Boolean set to True after a succesful run of macro
Exit Sub ' Normal succesful run of macro end
Bed:
Debug.Print "Not done " & """" & UsrNme & """" & " Error is " & Err.Number & ": " & Err.Description
Open ThisWorkbook.Path & "\" & "CDOSendMailAttempt " & Format(Date, "dddd dd mmmm yyyy") & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, "Fail " & Format(Now(), "hh mm") & " " & Err.Number & ": " & Err.Description & vbLf
Close #Highway1
' ' On Error GoTo -1 ' This takes out of the exceptional error handling state, so that the Error handler will work again ... not needed as the sub ends
' Ending Sub with FagerMe still set at False
End Sub