outlook群发带不同附件的邮件给不同的人

huachixt

想发送每个月的PDF的工资单单独给每位员工，之前有找到其他大神分享的发送模板，想请问下如何添加一个附件EXCEL中attachment设置为存放路径还是直接放附件在里面？要如何修改？

huachixt

能发送邮件的源代码，现在不知道怎么加attachment.

Sub SendEmail()
  Dim OutlookApp As Object
  Dim MItem As Object
  Dim cell As Range
  Dim Subj As String
  Dim EmailAddr As String
  Dim Recipient As String
  Dim Bonus As String
  Dim Msg As String
  
  'Create Outlook object
  Set OutlookApp = CreateObject("Outlook.Application")
  
  'Loop through the rows
  For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "*@*" Then
      'Get the data
      Subj = "Your Annual Bonus"
      Recipient = cell.Offset(0, -1).Value
      EmailAddr = cell.Value
      Bonus = Format(cell.Offset(0, 1).Value, "$0,000.")
            
     'Compose message
      Msg = "Dear " & Recipient & vbCrLf & vbCrLf
      Msg = Msg & "I am pleased to inform you that "
      Msg = Msg & "your annual bonus is "
      Msg = Msg & Bonus & vbCrLf & vbCrLf
      Msg = Msg & "William Rose" & vbCrLf
      Msg = Msg & "President"
   
      'Create Mail Item and send it
      Set MItem = OutlookApp.CreateItem(0)
      With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Display
        .send
        
        'NOTE: To actually send the emails, use .Send instead of .Display
        '.Send
      End With
    End If
  Next
End Sub

约定的童话

Sub 添加附件()
    Application.ScreenUpdating = False
    Dim MyName, i, arr
    arr = [a1].CurrentRegion
    MyName = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
    Do While MyName <> ""
        For i = 2 To UBound(arr) '隐藏一对多添加功能
            If arr(i, 5) = Split(MyName, ".")(0) Then
                arr(i, 4) = MyName
                Exit For
            End If
        Next
        MyName = Dir
    Loop
    [a1].CurrentRegion = arr
    MsgBox "附件添加完毕！", , "报告！"
End Sub

Sub 发送邮件()
    Dim i, arr
    Dim OutlookApp As Outlook.Application
    Dim OutlookItem As Outlook.MailItem
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        收件地址 = arr(i, 1): 主题 = arr(i, 2): 内容 = arr(i, 3): 附件 = arr(i, 4)
        Set OutlookApp = New Outlook.Application
        Set OutlookItem = OutlookApp.CreateItem(olMailItem)
        On Error GoTo 错误
        With OutlookItem
            .To = 收件地址
            .Subject = 主题
            .Body = 内容
            If 附件 <> "" Then
                .Attachments.Add ThisWorkbook.Path & "\" & 附件
            End If
            .Send
        End With
    Next
发送提示:
    MsgBox "发送OK，注意查收！", , "温馨提示！"
    Exit Sub
错误:
    MsgBox "邮件发送失败！", , "温馨提示！"
    Resume 发送提示
End Sub
目标区域你自己修改下

huachixt

约定的童话 发表于 2020-4-25 08:41
Sub 添加附件()
    Application.ScreenUpdating = False
    Dim MyName, i, arr

超级感谢，但是其实我是小白，是直接复制就可以用吗？

约定的童话

huachixt 发表于 2020-4-26 08:57
超级感谢，但是其实我是小白，是直接复制就可以用吗？

可能会报错，代码你看不懂的话没法改啊

huachixt

约定的童话 发表于 2020-4-26 08:59
可能会报错，代码你看不懂的话没法改啊

能不能直接帮忙在附件表格中改下呀。 那个Msg 的句子我自己编辑就可以 ，超级感恩。

闻启学

约定的童话 发表于 2020-4-25 08:41
Sub 添加附件()
    Application.ScreenUpdating = False
    Dim MyName, i, arr

很好奇 添加附件  与发送邮件这两段代码 有关系吗 ？？？
添加附件 就是这句就行   .Attachments.Add ThisWorkbook.Path & "\" & 附件

huachixt

闻启学 发表于 2020-4-26 11:35
很好奇 添加附件  与发送邮件这两段代码 有关系吗 ？？？
添加附件 就是这句就行   .Attachments.Add T ...

这个要添加到DIM 上面吗？

huachixt

添加报错信息，求帮助

约定的童话

闻启学 发表于 2020-4-26 11:35
很好奇 添加附件  与发送邮件这两段代码 有关系吗 ？？？
添加附件 就是这句就行   .Attachments.Add T ...

第一段准确来说叫添加工作簿名称，主要是获取名称用的