- 帖子
- 20
- 主題
- 5
- 精華
- 0
- 積分
- 61
- 點名
- 0
- 作業系統
- xp
- 軟體版本
- 2003
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣桃園
- 註冊時間
- 2010-9-1
- 最後登錄
- 2019-4-26
|
利用vba發mail的問題
各位大大，最近我寫了一個自動發mail的程式，但遇到了2個問題，不知道有沒有人可以幫我解決一下，謝謝。
以下是我的程式碼：
1.這個程式碼有時候會寄不出去，我測試2~3個人時都是正常的，但人數超過20個人以上就容易發生寄不出去
2.outlook 2010時會出現安全性問題，也容易造成mail寄不出去
Sub Auto_SendMail()
On Error Resume Next
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
Sheets("Setting Sheet").Select
Email = ""
Email_cc = ""
'確認收件人與副件人員名單是否是空的
If WorksheetFunction.CountA(Columns(18)) < WorksheetFunction.CountA(Columns(19)) Then
MsgBox "抄送人数不可大于正常收件者人数，请重新确认，谢谢。"
Set objMail = Nothing
Set objOutlook = Nothing
Exit Sub
Else
If WorksheetFunction.CountA(Columns(18)) <= 1 Then
MsgBox "正常收件者人数不得为空，请重新确认，谢谢。"
Set objMail = Nothing
Set objOutlook = Nothing
Exit Sub
End If
End If
For r = 2 To WorksheetFunction.CountA(Columns(18))
Email = Sheets("Setting Sheet").Cells(r, 18) & ";" & Email
If Sheets("Setting Sheet").Cells(r, 19) <> "" Then
Email_cc = Sheets("Setting Sheet").Cells(r, 19) & ";" & Email_cc
End If
Next r
' Compose the message
Msg = ""
Msg = Msg & "Dear all," & vbCrLf & vbCrLf
Msg = Msg & "附件Excel是測試 Data - " & Format(Now(), "YYYY/MM/DD") & " " & Format(Now(), "HH:00(AM/PM)") & "数据。" & vbCrLf & vbCrLf
Msg = Msg & "数据是从" & Format(Now() - 2, "YYYY/MM/DD") & " 00:00 至 " & Format(Now(), "YYYY/MM/DD") & " " & Format(Now(), "HH:00(AM/PM)") & "（测试时间点）。" & vbCrLf & vbCrLf
Msg = Msg & "Best Regards!"
' Message subject
Subj = "test mail!!"
With objMail
.To = Email
.CC = Email_cc
.Subject = Subj
.Body = Msg
.Attachments.Add Save_File_Path & "AAAA_" & Format(Now(), "YYYYMMDD") & "_" & Format(Now(), "HH(AM/PM)") & ".xlsm"
.Display
.Send
End With
Set objMail = Nothing
Set objOutlook = Nothing
End Sub |
|
發表於 2012-10-17 13:16
| 
