问题描述:

I am quite new in excel VBA programing. I have to rewrite code which works fine on Win but doesn't on Mac. When I run the code I got error:

Run-time error '429', ActiveX component can't not create object at

line: Set iMsg = CreateObject("CDO.Message").

I already Google thru Internet and haven't found anything which could help me.

Can someone please help me how to fix this problem.

Any idea will be welcome.

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

相关阅读:
Top