EXCEL通过VBA添加多个多个OUTLOOK附件

right1406

各位大神，有一个EXCEL模板，可以通过此模板批量发送OUTLOOK邮件，并可以实现不同邮件不同附件，但是有一个问题，不能添加多个附件，希望大神帮助修改代码，谢谢！
模板中：
A列是邮件标题；
B列是收件人名称；
C列是收件人收件箱；
D-J列是邮件附件的名称；（现在发送只能放入D列的附件，其他列的VBA放不进去）
K列是邮件正文。

Sub 全自动发送邮件()
    Dim myOlApp As Object
    Dim myitem As Object
    Dim i As Integer, j As Integer
    Dim strg As String
    Dim atts As Object
    Dim mycc As Object
    Dim myfile As String
    Set myOlApp = CreateObject("Outlook.Application")
    '设置对Sheet1工作表进行操作，可自行修改
    With Sheets("Sheet1")
        i = 2  '第一行为标题行，从第二行开始
        Do While .Cells(i, 2) <> "" '本例中判断当某行第二列为空时，停止发送邮件
                   '设置调用Outlook来发送邮件
        Set myitem = myOlApp.CreateItem(0)
        Set atts = myitem.Attachments
        myitem.To = .Cells(i, 3)    '收件人邮箱地址调用了第3列邮箱的数据
        myitem.Subject = .Cells(i, 1)             '标题调用了第1列的数据
        myitem.Body = .Cells(i, 11)
        myfile = Dir(ThisWorkbook.Path & "\" & .Cells(i, 4))  '在本工作薄的根目录下找出附件，且附件的文件名是第四列数据
        If myfile <> "" Then myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile, 1
         '预览，如果想直接发送，把.display改为.send
           'myitem.send
            myitem.display
            i = i + 1
            strg = ""
        Loop
    End With
    Set myitem = Nothing
    End Sub

tyxvba7529

请参考代码

1. '        添加附件开始
   
2.             myfile = Dir(ThisWorkbook.Path & "" & Cells(i, 4) & "*")
   
3.             Do
   
4.                 myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
   
5.                 myfile = Dir
   
6.               Loop Until myfile = ""
   
7. '              添加附件结束

复制代码

tyxvba7529

'        添加附件开始
            myfile = Dir(ThisWorkbook.Path & "\" & Cells(i, 4) & "*")
            Do
                myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile, 1
                myfile = Dir
              Loop Until myfile = ""
'              添加附件结束

PennZou

多个附件的话，直接定义就好，多谢几行.Attachments.Add

Dim myfile1 As String
Dim myfile2 As String
       myfile1 = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 2) & "*.*")
       myfile2 = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")
       Do Until myfile1 = ""
          myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile1, 1
          myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile2, 1
          myfile1 = Dir
Loop

SUNJDO

楼主你好，请问你的问题解决了吗？我想需要做一个询价的一键自动发邮件的的表格，和你这个类似，但是你的模板里的宏代码有错误，看不了，我是VBA小白，能否再发一份你的模板？谢谢！我的邮箱：jiandong.sun@me.com

henterwu

        ' 添加附件
        If Sheet6.Cells(i, 5).Value <> "" Then '附件栏是否为空
        If InStr(Cells(i, 5), ";") < 0 Then        '是否有多个附件
            OutlookMail.Attachments.Add Cells(i, 5).Value   '添加单个附件
            Else:
        att = Split(Cells(i, 5).Value, ";")
          For j = 0 To UBound(att)                                  '添加每个附件  ，附件地址间用“;”隔开
          OutlookMail.Attachments.Add att(j)
          Next j
        End If
        End If

henterwu

        ' 添加附件
        If Sheet6.Cells(i, 5).Value <> "" Then                      '附件栏是否为空
        If InStr(Cells(i, 5), ";") = 0 Then                             '是否多附件
            OutlookMail.Attachments.Add Cells(i, 5).Value
            Else:
        att = Split(Cells(i, 5).Value, ";")                             '多附件地址间用“;”隔开
          For j = 0 To UBound(att)
          OutlookMail.Attachments.Add att(j)                      '逐个加载附件
          Next j
        End If
        End If
使用与批发邮件时用。