ActiveX 429 错误：将 VBA 电子邮件代码从 Windows 移植到 Mac

Question

我已经阅读了很多关于这个主题的问题，包括 macexcel.com，但没有找到解决我独特情况的答案。我不知道是否有任何特定的代码行已知不能在 Mac 上运行。该代码在 Windows 10 上运行良好。任何建议都非常感谢。

Sub SendEmailsBulk_Init()
'This solution checks for rows with emails and looks at column AD for blank value
    Dim i As Long
    Dim lr As Integer
    Dim ws As Worksheet
    Dim Response, u As Long
    Dim body As Range
    Dim subj As String
    Dim STo As String
    Dim SendFromAcnt As String
    Dim SendFromAcntPswrd As String
    Dim Rslt As Integer
    
    u = 0
    '''''Application.ScreenUpdating = False
    Set ws = Sheet1
    lr = ws.Cells(Rows.Count, "E").End(xlUp).Row
    Rslt = MsgBox("Do you want to continue with sending a Gmail?", vbYesNo, "Please Respond")
    If Rslt = "6" Then

    SendFromAcnt = ws.Range("A2")
    SendFromAcntPswrd = ws.Range("A4")
    For i = 2 To ws.Cells(Rows.Count, "E").End(xlUp).Row
        If ((ws.Cells(i, "E").Value) <> "") And (ws.Cells(i, "H").Value = "") _
        And (ws.Cells(i, "I").Value = "") Then ' Email, sent-Notsent,Response
            Set body = ws.Range("R" & i)
            subj = ws.Cells(i, "K")
            STo = ws.Cells(i, "E").Value & ";" & Sheet1.Cells(i, "F").Value
            send_email_Gmail j:=i, rng:=body, Subject:=subj, Sendto:=STo, SFA:=SendFromAcnt, SFAP:=SendFromAcntPswrd, SendNow:=Response = vbYes
            ws.Cells(i, "I").Value = Date
            u = u + 1
        End If
        
    Next i
    
    If u = 0 Then
        MsgBox "No Email has been generated due to no email values, emails previously sent or Response received on email"
    ElseIf u > 0 Then
        MsgBox u & " Email(s) has/have been created"
    End If
    
    Else
        MsgBox "The code will now exit and not send any emails.", vbInformation, "Result"
    End If
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Sub SendEmailsBulk_Init_O()
'This solution checks for rows with emails and looks at column AD for blank value
    Dim i As Long
    Dim lr As Integer
    Dim ws As Worksheet
    Dim Response, u As Long
    u = 0
    Application.ScreenUpdating = False
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(Rows.Count, "E").End(xlUp).Row 'For troubleshooting
    
          Response = MsgBox(prompt:="Do you want to send the emails immediately?" & vbCrLf & _
                                "Yes to send immediately" & vbCrLf & _
                                "No to generate and display them, but can be sent manually", _
                        Buttons:=vbYesNoCancel)
    
    For i = 2 To ws.Cells(Rows.Count, "E").End(xlUp).Row
        If ((ws.Cells(i, "E").Value) <> "") And (ws.Cells(i, "I").Value = "") _
        And (ws.Cells(i, "H").Value = "") Then ' Email, sent-Notsent,Response
            Send_newemaili j:=i, SendNow:=Response = vbYes
            ws.Cells(i, "I").Value = Date
            u = u + 1
        End If
        
    Next i
    
    If u = 0 Then
        MsgBox "No Email has been generated due to no email values, emails previously sent or Response received on email"
    ElseIf u > 0 Then
        MsgBox u & " Email(s) has/have been created"
    End If
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Sub Send_newemaili(j As Long, SendNow As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim rngt As Range

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Set rng = Sheet1.Range("R" & j)
    
    With OutMail
            .To = Sheet1.Cells(j, "E").Value & ";" & Sheet1.Cells(j, "F").Value
            .CC = ""
            .Subject = Sheet1.Cells(j, "K")
            .HTMLBody = rng
            If SendNow Then
                .Send
            Else
                .Display
            End If
            End With
            
   Set OutMail = Nothing
   Set OutApp = Nothing
    
End Sub

Sub send_email_Gmail(j As Long, rng As Range, Subject As String, Sendto As String, SFA As String, SFAP As String, SendNow As Boolean)

Dim CDO_Mail As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strbody As String


strSubject = Subject
strFrom = SFA '"email@gmail.com" '
strTo = Sendto 'Sheet1.Cells(j, "E").Value & ";" & Sheet1.Cells(j, "F").Value
strCc = ""
strBcc = ""
strbody = rng

Set CDO_Mail = CreateObject("CDO.Message")
On Error GoTo Error_Handling

Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1

Set SMTP_Config = CDO_Config.Fields

With SMTP_Config
 .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SFA '"email@gmail.com"
 .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SFAP ' password
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
 .Update
End With

With CDO_Mail
 Set .Configuration = CDO_Config
End With

CDO_Mail.Subject = strSubject
CDO_Mail.From = strFrom
CDO_Mail.To = strTo
CDO_Mail.textbody = ""
CDO_Mail.HTMLBody = "< HTML >< BODY >" & strbody & "</ BODY >< /HTML >" 'strbody '
CDO_Mail.CC = strCc
CDO_Mail.BCC = strBcc
CDO_Mail.Send

Error_Handling:
If Err.Description <> "" Then MsgBox Err.Description

End Sub

在ExcelForum 429 Error交叉发布

Answer 1

您正在使用 CDO 发送邮件（请参阅 CreateObject 行）。 CDO 只是一个 Windows 的 ActiveX 库，它不存在于 Mac，因此有关 ActiveX 的错误（它是一个在 Mac 上也不存在的对象框架）。您需要找到一种不同的方式在 Mac 上发送邮件。