用EXCEL批量outlook发送邮件，如果附件没有就不发送

funsz

批量发送的表格是盗用的，我每天都要固定发送一批清单给一批人，有时候某个人不需要发送因为没有清单给他，
怎么修改，如例子，1是没附件，2是有附件的，1不需要发送。

funsz

求解啊，完全是新手，不懂如何改代码

funsz

自己尝试改了下，能满足没附件邮件不发送，但是无法自动关闭没有发送的邮件，需要手动关闭，有办法可以自动关闭吗？
群发邮件.rar (34.06 KB, 下载次数: 85)

2015-3-18 12:38 上传

点击文件名下载附件

leao6

转存为较高版本的EXCEL文件可解决这个问题，比如2007,2010，后缀为*.xlsx

funsz

leao6 发表于 2015-3-19 14:04
转存为较高版本的EXCEL文件可解决这个问题，比如2007,2010，后缀为*.xlsx

要改成*.xlsm的后缀吧，还是不行吧，我试了，要改下代码？

炕炕41

求问最后解决了吗？我也想实现这个功能，但总是报错T.T

funsz

炕炕41 发表于 2017-8-9 17:35
求问最后解决了吗？我也想实现这个功能，但总是报错T.T

你指的是哪块问题？

炕炕41

funsz 发表于 2017-8-11 09:36
你指的是哪块问题？

没有附件则不发送这个功能

funsz

炕炕41 发表于 2017-8-14 11:20
没有附件则不发送这个功能

1. Function GetBoiler(ByVal sFile As String) As String
   
2. Dim fso As Object
   
3. Dim ts As Object
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
   
6.     GetBoiler = ts.readall
   
7.     ts.Close
   
8. End Function
   
9. Function IsFileExists(ByVal strFileName As String) As Boolean
   
10.     If Dir(strFileName, 16) <> Empty Then
    
11.         IsFileExists = True
    
12.     Else
    
13.         IsFileExists = False
    
14.     End If
    
15. End Function
    
16. Sub sendmail()
    
17. '先通过VBA窗口"工具"菜单--"引用"选择 "Microsoft outlook 11.0 object Library，同时已在Outlook中设置可发送邮件的正常帐号
    
18. On Error Resume Next
    
19. Dim rowCount, endRowNo, endColumnsNo
    
20. Dim objOutlook As New Outlook.Application
    
21. Dim objMail As MailItem
    
22. Dim strbody As String
    
23. Dim SigString As String
    
24. Dim Signature As String
    
25. 
    
26. endRowNo = Cells(1, 1).CurrentRegion.Rows.Count     '行数计算
    
27. endColumnsNo = Cells(1, 1).CurrentRegion.Columns.Count
    
28. Set objO = New Outlook.Application  '创建objO为Outlook应用程序对象
    
29.     For rowCount = 2 To endRowNo
    
30.         Set objMail = objOutlook.CreateItem(olMailItem)
    
31.         strbody = Cells(rowCount, 4)
    
32.         SigString = Environ("appdata") & "\Microsoft\Signatures\签名.htm"     '获取签名路径
    
33.         If Dir(SigString) <> "" Then    '判断签名路径存在，存在则获取签名
    
34.             Signature = GetBoiler(SigString)
    
35.         Else
    
36.             Signature = ""
    
37.         End If
    
38. 
    
39.         With objMail
    
40.             .To = Cells(rowCount, 1)        '收件人
    
41.             .CC = Cells(rowCount, 2)        '抄送人
    
42.             .Subject = Cells(rowCount, 3)   '主题栏
    
43.             '.Body = Cells(rowCount, 4)     '正文比较简单可以使用这样
    
44.             .HTMLBody = strbody & "<br><br>" & Signature    '推荐使用HTML格式的正文
    
45.             
    
46.             a = 0
    
47.             For i = 5 To endColumnsNo
    
48.                 If Sheets("Sheet1").Cells(rowCount, i).Value <> "" Then
    
49.                     .Display
    
50.                     .Attachments.Add ThisWorkbook.Path & Cells(rowCount, i).Value
    
51.                     If IsFileExists(ThisWorkbook.Path & Cells(rowCount, i).Value) = True Then a = a + 1
    
52.                 End If
    
53.             Next i
    
54.             If a > 0 Then
    
55.                 .Send
    
56.             Else
    
57.                 Application.SendKeys "%{F4}n"
    
58.             End If
    
59.         End With
    
60.         Set objMail = Nothing
    
61.     Next
    
62. Set objOutlook = Nothing
    
63. End Sub

复制代码

dandysor

funsz 发表于 2017-8-15 14:59

你好，大侠，第一封邮件可以有多个附件，但第二封邮件，就没有多个附件了，请问怎么解决呢？盼复，谢谢。