我是我的高尔夫俱乐部高级部门的赛程秘书，那里的大量管理工作都是手动完成的。 我正在尝试尽可能地自动化事情，发送电子邮件是一项任务。 我需要一个解决方案，其中 Outlook 不是答案 - 因此尝试使用 Gmail - 因为 6 人委员会中的 4 人只有新的 Outlook 应用程序（不是 Office 的一部分），而且还不支持自动化。
到目前为止，我已经在 Stack Overflow 和 YouTube 上找到了许多关于在 VBA 中使用 Gmail 设置自动电子邮件问题的可行解决方案。 那些能够证明其有效的应用程序均来自 2020 年/之前。其中许多是指让您的 Google 帐户使用不太安全的应用程序。 现在这已被淘汰，不再是一种选择。 我的 Gmail 帐户和电子邮件于 2025 年 1 月 2 日设置。
我已设置激活的 2 阶段验证并生成应用程序密码，并按照本论坛和其他论坛 (fora) 中类似问题的各种回复中所述使用它们。
没有什么能让我克服 SendUsing 配置无效的错误消息。
在错误消息框中，我收到运行时错误'-2147220960 (80040220)“SendUsing”配置无效。
我的代码如下，在参考文献中我已“勾选”Microsoft CDO for Windows 2000 库。 我还没有找到更新版本的 CDO。我在 i7 11700K CPU 和 32Gb RAM 上运行 Windows 11 Pro 24H2。
Option Compare Database
' Global variables
Dim newMail As CDO.Message
Dim newConfiguration As CDO.Configuration
Dim Fields As Variant
Dim msConfigURL As String
' References include Microsoft CDO for Windows 2000 Library
Sub Send_Email()
‘ Create error handler
On Error GoTo errHandle
' Create the new instances of the objects
Set newMail = New CDO.Message
Set newConfiguration = New CDO.Configuration
' Set all the default values
newMail.Configuration.Load -1
' Put in the message info
With newMail
.Subject = "VBA Test"
.From = “**********@gmail.com” ‘ A valid and working Gmail account with email enabled
.To = “*********@outlook.com” ‘ An email address that I keep for testing purposes
.TextBody = "Test message sent using VBA script in Access"
End With
' Set the configuration
msConfigURL = "https://schemas.microsoft.com/cdo/configuration"
' Make the Fields
Set Fields = newConfiguration.Fields
With Fields
.Item(msConfigURL & "/sendusername") = "**********@gmail.com"
.Item(msConfigURL & "/sendpassword") = "**************" ‘ I have tried the account password and the generated App Password
.Item(msConfigURL & "/smtpusesssl") = True
.Item(msConfigURL & "/smtpauthenticate") = 1
.Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2
' Update the configuration
.Update
End With
' Transfer the configuration
newMail.Configuration = newConfiguration
' Send the email
newMail.Send
MsgBox "Email has been sent", vbInformation
' Exit lines for routine
exit_line:
' Release object from memory
Set newMail = Nothing
Set newMessage = Nothing
Exit Sub
' Error handling
errHandle:
Select Case Err.Number
Case -2147220973 'Could be because of Internet Connection
MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
Case Else 'Report other errors
MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
End Select
Resume exit_line
End Sub
我错过了什么？ 当有人向我指出这一点时，我会感到多么愚蠢？
GMail 需要 TLS 来进行 SMTP 连接。不幸的是，CDO 不直接支持 TLS。然而，有一个相当不错的解决方法，允许您使用 CDO 通过 GMail 发送电子邮件。首先您需要访问此链接并下载以下三个文件：
cAsyncSocket.cls
cTlsSocket.cls
mdTlsNative.bas
使用 VB 编辑器将这些文件导入 Access。
这些文件中的代码是 VB6，需要进行一些小的修改才能使其在 VBA 中工作。我已经包含了参考代码行，以便您可以找到修改代码的正确位置。您需要对 cAsyncSocket 类进行这些代码更改。首先找到以下代码段并添加 GetCurrentThreadID 行，如图所示：
'--- for Modern Subclassing Thunk (MST)
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const SIGN_BIT As Long = &H80000000
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long '<<< ADD THIS LINE
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
现在转到同一类模块 (
InitAsyncSelectNotifyThunkcAsyncSocket aParams(0) = ObjPtr(pObj)
aParams(1) = pfnCallback
If hThunk = 0 Then
Dim lngTId As Long '<<< ADD THIS LINE
lngTId = GetCurrentThreadId() '<<< ADD THIS LINE
' hThunk = pvThunkGlobalData("InitAsyncSelectNotifyThunk" & App.ThreadID) <<< COMMENT/DELETE THIS LINE
hThunk = pvThunkGlobalData("InitAsyncSelectNotifyThunk" & lngTId) '<<< ADD THIS LINE
End If
'--- for IDE protection
Debug.Assert pvThunkIdeOwner(aParams(7))
If aParams(7) <> 0 Then
aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
End If
' pvThunkGlobalData("InitAsyncSelectNotifyThunk" & App.ThreadID) = hThunk <<< COMMENT/DELETE THIS LINE
pvThunkGlobalData("InitAsyncSelectNotifyThunk" & lngTId) = hThunk '<<< ADD THIS LINE
End If
lSize = CallWindowProc(hThunk, hWnd, 0, VarPtr(aParams(0)), VarPtr(InitAsyncSelectNotifyThunk))
Debug.Assert lSize = THUNK_SIZE
End Function
代码修改就这样了。现在您需要访问 https://www.vbforums.com/showthread.php?894683-RESOLVED-VB6-QUESTION-CDO-Email-Guide-and-STARTTLS，其中包含您将在运行时使用的代码（代码如下）。向下滚动到 2021 年 12 月 29 日中午 12:44 于
wqwetocSmtpProxyOption Explicit
DefObj A-Z
'Private Const MODULE_NAME As String = "cSmtpProxy"
'=========================================================================
' Public events
'=========================================================================
Event RecvFromClient(Data() As Byte)
Event RecvFromServer(Data() As Byte)
'=========================================================================
' Constants and member variables
'=========================================================================
Private m_sServerAddress As String
Private m_lServerPort As Long
Private WithEvents m_oListen As cTlsSocket
Private WithEvents m_oClient As cTlsSocket
Private WithEvents m_oServer As cTlsSocket
'=========================================================================
' Properties
'=========================================================================
Public Property Get ServerAddress() As String
ServerAddress = m_sServerAddress
End Property
Public Property Get ServerSocket() As cTlsSocket
Set ServerSocket = m_oServer
End Property
Public Property Get ClientSocket() As cTlsSocket
Set ClientSocket = m_oClient
End Property
'=========================================================================
' Methods
'=========================================================================
Public Function Init(sServerAddress As String, ByVal lServerPort As Long, ByVal lLocalPort As Long, Optional sLocalAddress As String) As Boolean
m_sServerAddress = sServerAddress
m_lServerPort = lServerPort
Set m_oListen = New cTlsSocket
If Not m_oListen.Create(lLocalPort, SocketAddress:=sLocalAddress) Then
GoTo QH
End If
If Not m_oListen.Listen() Then
GoTo QH
End If
'--- success
Init = True
QH:
End Function
Private Sub pvInjectStartTls(sText As String)
If Left$(sText, 5) <> "EHLO " Then
GoTo QH
End If
If Not m_oServer.SyncSendText(sText) Then
GoTo QH
End If
sText = m_oServer.SyncReceiveText()
If LenB(sText) = 0 Then
GoTo QH
End If
sText = "STARTTLS" & vbCrLf
If Not m_oServer.SyncSendText(sText) Then
GoTo QH
End If
sText = m_oServer.SyncReceiveText()
If LenB(sText) = 0 Then
GoTo QH
End If
If Not m_oServer.SyncStartTls(m_sServerAddress) Then
GoTo QH
End If
QH:
End Sub
'=========================================================================
' Socket events
'=========================================================================
Private Sub m_oListen_OnAccept()
Set m_oServer = New cTlsSocket
If Not m_oServer.Connect(m_sServerAddress, m_lServerPort, UseTls:=False) Then
Set m_oServer = Nothing
GoTo QH
End If
Set m_oClient = New cTlsSocket
m_oListen.Accept m_oClient, UseTls:=False
QH:
End Sub
Private Sub m_oServer_OnReceive()
Dim baBuffer() As Byte
If m_oServer.ReceiveArray(baBuffer) Then
RaiseEvent RecvFromServer(baBuffer)
m_oClient.SendArray baBuffer
End If
End Sub
Private Sub m_oClient_OnReceive()
Dim baBuffer() As Byte
If m_oClient.ReceiveArray(baBuffer) Then
pvInjectStartTls StrConv(baBuffer, vbUnicode)
RaiseEvent RecvFromClient(baBuffer)
m_oServer.SendArray baBuffer
End If
End Sub
Private Sub m_oClient_OnClose()
m_oServer.Close_
End Sub
第二个代码块显示了如何启动 SMTP 代理。在所示的示例中，它位于 Form_Load 事件中，尽管您可以将此代码放在您认为合适的任何位置（例如命令按钮）：
Option Explicit
Private m_oProxy As cSmtpProxy
Private Sub Form_Load()
Set m_oProxy = New cSmtpProxy
If Not m_oProxy.Init("smtp.gmail.com", 25, 10025) Then
GoTo QH
End If
QH:
End Sub
最后的代码块展示了如何使用 CDO 通过 GMail 创建和发送电子邮件。这非常符合新的 GMail 安全要求。您所需要的只是您的 GMail 帐户和您已经生成的应用程序密码：
Private Sub pvSendMail()
Const CONFIG As String = "http://schemas.microsoft.com/cdo/configuration/"
Dim oMsg As Object
Set oMsg = CreateObject("CDO.message")
With oMsg.Configuration.Fields
.Item(CONFIG & "sendusing") = 2
.Item(CONFIG & "smtpserver") = "127.0.0.1"
.Item(CONFIG & "smtpserverport") = 10025
.Item(CONFIG & "smtpauthenticate") = 1
.Item(CONFIG & "sendusername") = "***@gmail.com"
.Item(CONFIG & "sendpassword") = "***"
.Update
End With
With oMsg
.To = "***@saas.bg"
.From = "***@gmail.com"
.Subject = "the email subject"
.TextBody = "the full message body goes here. you may want to create a variable to hold the text"
.Send
End With
End Sub
我把这两个网站上的所有这些零碎的东西放在一起，它确实有效。是的，它很冗长，需要一些努力才能组合在一起，但它确实很有效。关键似乎是 CDO 具有隐藏的功能，可以启动 TLS，但仅在端口 25 上。此解决方案的所有功劳必须归于在两个网站上发布此信息的
wqweto