问题描述
我已经阅读了许多关于这个主题的问题，包括 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,"I").Value = "") _
And (ws.Cells(i,"H").Value = "") Then ' Email,Response
Send_newemaili j:=i,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 protected]" '
strTo = Sendto '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 protected]"
.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
解决方法
暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！
如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。
小编邮箱:dio#foxmail.com (将#修改为@）