Question

我有一个名称，电子邮件，附件名称的列表，我需要发送电子邮件并附加这些附件，如果我指定了附件的数量，我的宏就起作用了，但是我所得到的不是每个名称/的固定数目的附件/电子邮件，有时是一个，有时不止一个。您可以检查我的宏并建议我更改/添加什么以使附件动态化吗？

Sub CreateNewMessage()

Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object

Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)

Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailMid1, emailMid2, emailMid3, emailClose, emailCustom, emailSig As String

Dim AttachmentPath, AttachmentNm As String

AttachmentPath = [O1] & "\"

fColorBlue = "#003846"
fColorGreen = "#5e9732"
fColorRed = "#FF0000"
fDukeBlue1 = "#001A57"
fDukeBlue2 = "#00009C"
fAggieMaroon = "#500000"
fAggieGray = "#332C2C"

For Each ToCc In ActiveSheet.[A2:A100] 'This is the range for how many records (rows) you want to send email

    '=============================================================
    Dim ToEmail, CcEmail, ToNm, CcNm, CcLNm As String
    Dim DescrDt, LocID, LsmID, DescrNm As String
    Dim Attach1, Attach2, Attach3 As String

    ToNm = Cells(ToCc.Row, [To___fName].Column).Value
    CcNm = Cells(ToCc.Row, [Cc___fName].Column).Value
    CcLNm = Cells(ToCc.Row, [Cc___LName].Column).Value
    ToEmail = Cells(ToCc.Row, [To___Email].Column).Value
    CcEmail = Cells(ToCc.Row, [Cc___Email].Column).Value
    Attach1 = Cells(ToCc.Row, [Attachment1].Column).Value
    Attach2 = Cells(ToCc.Row, [Attachment2].Column).Value
    Attach3 = Cells(ToCc.Row, [Attachment3].Column).Value


    AttachmentNm1 = Attach1
    AttachmentNm2 = Attach2
    AttachmentNm3 = Attach3

    Dim FileAttach1 As String
    Dim FileAttach2 As String
    Dim FileAttach3 As String

    FileAttach1 = AttachmentPath & AttachmentNm1
    FileAttach2 = AttachmentPath & AttachmentNm2
    FileAttach3 = AttachmentPath & AttachmentNm3
    'MsgBox FileAttach1
    'MsgBox FileAttach2
    'MsgBox FileAttach3

'Exit Sub

    '=============================================================

    Set aEmail = aOutlook.CreateItem(0)

    With aEmail
        '.SentOnBehalfOfName = "name@company.com"
        .SentOnBehalfOfName = "name2@company.com"

        .To = ToEmail
        .cc = CcEmail '& "; " & SupvEmail & "; " & HREmail

        .Subject = "LSM Monthly Dashboard " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
        '.BodyFormat = olFormatPlain ' send plain text message
        '.BodyFormat = olFormatHTML
        '.Importance = olImportanceHigh
        '.Sensitivity = olConfidential

        .HTMLBody = emailContent

        'MsgBox FileAttach1

        .Attachments.Add FileAttach1
        .Attachments.Add FileAttach2
        .Attachments.Add FileAttach3

        .display
        '   .send
    End With

NEXT_ToCC:
    Set aEmail = Nothing
    Set olInsp = Nothing
    Set myDoc = Nothing
    Set oRng = Nothing
Next ToCc

End Sub

Answer 1

您应该使用数组来执行此操作。

将文件路径添加到数组。

昏暗文件（）文件=数组（path1，path2）

在“ htmlbody”之后写：

对于i = lbound（文件）到ubound（文件） .attachments.add文件（i）

下一个我

根据条件将电子邮件附件从Excel添加到Outlook

1 个答案: