自动发邮件的问题

sbww8800

1. Public Declare Function SetTimer Lib "user32" _
   
2.         (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
   
3. Public Declare Function KillTimer Lib "user32" _
   
4.         (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
   
5. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   
6. 
   
7. Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
   
8.     KillTimer 0, idEvent
   
9.     DoEvents
   
10.     Sleep 100
    
11.     '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了
    
12.     Application.SendKeys "%s"
    
13. End Function
    
14.   
    
15. '批量发送邮件
    
16. Sub BatchSendMail()
    
17.     Application.ScreenUpdating = False
    
18.     Sheet7.Activate
    
19.     [d1] = "D:\数据备份\入库资料" & Format(Now, "yyyymmddhhmm") & ".xlsx;D:\数据备份\统计表" & Format(Now, "yyyymmddhhmm") & ".xlsx"
    
20.     Dim rowCount, endRowNo
    
21.     endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
    
22.     '逐行发送邮件
    
23.     For rowCount = 1 To endRowNo
    
24.         SendMail Cells(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4)
    
25.     Next
    
26.     Sheet1.Activate
    
27.     Application.ScreenUpdating = True
    
28. End Sub
    
29. 
    
30. ' 发送多个附件的子程序
    
31. Sub SendMail(ByVal to_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String)
    
32.     Dim objOL As Object
    
33.     Dim itmNewMail As Object
    
34.     Dim attaches
    
35.     Dim attach
    
36.       
    
37.     '引用Microsoft Outlook 对象
    
38.     Set objOL = CreateObject("Outlook.Application")
    
39.     Set itmNewMail = objOL.CreateItem(olMailItem)
    
40.     With itmNewMail
    
41.         .subject = subject  '主旨
    
42.         .HTMLbody = body   '正文本文
    
43.         .To = to_who  '收件者
    
44.         .Display  '启动Outlook发送窗口
    
45.         attaches = Split(attachement, ";")
    
46.          
    
47.         For Each attach In attaches
    
48.             If (Len(attach) > 0) Then
    
49.                 .Attachments.Add attach
    
50.             End If
    
51.         Next
    
52.         SetTimer 0, 0, 0, AddressOf WinProcA
    
53.     End With
    
54.       
    
55.     Set objOL = Nothing
    
56.     Set itmNewMail = Nothing
    
57. End Sub
    

复制代码

找几天了，一直没解决，要自动发送邮件，上面代码要先打开outlook才能发送，没打开就一直躺在发件箱里，直到打开outlook才发送，这能解决吗？望大侠出手

闻启学

楼主的代码真奇怪  我修改几次都不成功


这个是我的另一个发送邮件代码
群发邮件 ,多个附件（完成）.zip (21.08 KB, 下载次数: 41)

2015-7-7 22:29 上传

点击文件名下载附件