excel - 从 Excel 发送邮件 - 运行时错误 '429' : ActiveX component can't create object

Question

我必须重写适用于 Win 但不适用于 Mac 的代码。

当我运行代码时出现错误:

Run-time error '429': ActiveX component can't create object

在线: Set iMsg = CreateObject("CDO.Message") .

我已经通过互联网谷歌了。

Dim msgbox1
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim xRange As Range
Dim xCell As Long
Dim xCount As Long
Dim i As Long

' First run the checks that all needed info is there
' before we display the form

If frmEmail.fldSubject.TextLength < 5 Then
    MsgBox "Please fill in a subject for the email", vbExclamation
    Exit Sub
End If

If frmEmail.fldEmailBox.TextLength < 5 Then
    MsgBox "Please put some information in the email body", vbExclamation
    Exit Sub
End If

msgbox1 = MsgBox("Are you sure you want to email all selected users in this Directorate: " & _
vbCrLf & vbCrLf & Worksheets("Contact Info").Cells(12, 4), vbOKCancel + vbExclamation, "Attention! Attention!! Attention!!!")

If msgbox1 = vbOK Then
    msgbox1 = MsgBox("Are you sure you want to email all users using the following SMTP server: " & _
    vbCrLf & vbCrLf & Worksheets("ADMIN").Cells(25, 3), vbOKCancel + vbExclamation, "Attention! Attention!! Attention!!!")

    If msgbox1 = vbOK Then
        Rem msgbox1 = MsgBox("Place holder for email function")
        'Here we go with emailing
        Sheets("Users Details Form").Activate
        Set iMsg = CreateObject("CDO.Message")
        Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Trim(Worksheets("ADMIN").Range("c24").Value)
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With

        Set xRange = Worksheets("Users Details Form").Range("A1:A65536")
        xCount = Application.CountIf(xRange, "x")

        For i = 1 To xCount
            strbody = frmEmail.fldEmailBox.Text
            xCell = xRange.Find("x").Row

            strbody = Replace(strbody, "%%user%%", Range("B" & xCell) & " " & Range("C" & xCell))
            strbody = Replace(strbody, "%%username%%", Range("F" & xCell))
            strbody = Replace(strbody, "%%password%%", Range("G" & xCell))
            strbody = Replace(strbody, "%%role%%", Range("H" & xCell))

            On Error Resume Next
            With iMsg
                Set .Configuration = iConf
                .To = Range("D" & xCell).Value
                .CC = ""
                .BCC = ""
                .From = "" & Worksheets("ADMIN").Range("C22").Value & "<" & Worksheets("ADMIN").Range("C23").Value & ">"
                .Subject = frmEmail.fldSubject.Text
                .TextBody = strbody
                .Send
            End With
            If Err.Number <> 0 Then
                Range("A" & xCell).Value = "F"
                Range("A" & xCell).DisplayFormat.Interior.ColorIndex = iRed
            Else
                If frmEmail.btnNewUserEmail Then
                    Range("A" & xCell).Value = "N"
                    Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
                End If
                If frmEmail.btnExistingUserEmail Then
                    Range("A" & xCell).Value = "E"
                    Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
                End If
                If frmEmail.btnCustom Then
                    Range("A" & xCell).Value = "C"
                    Range("A" & xCell).DisplayFormat.Interior.ColorIndex = Range("A1").DisplayFormat.Interior.ColorIndex
                End If
            End If
            On Error GoTo 0
        Next
    End If
End If
End

Answer 1

通过转到 VBA 编辑器中的工具->引用来检查您的引用，确保没有一个被标记为“缺失”。

如果没有缺少引用，则通常这是由于工作簿损坏。

解决方案是创建一个新工作簿并将您的 VBA 代码复制到其中。

这意味着您将需要重新创建损坏的工作簿中可能存在的任何工作表、格式等。