Question

我想修改此脚本，以在其创建的电子邮件中包含附件。工作表上的单元格F5＆＃34;说明＆＃34;包含文件路径。我尝试使用来自几个不同来源的信息对其进行修改。

这是一个工作版本，预先附件尝试：

Sub CreateMails()

     Dim objOutlook As Object
     Dim objMail As Object
     Dim rngTo As Range
     Dim rngSubject As Range
     Dim rngBody As String
     Dim rngAttach As Range
     Dim SigString As String

     Set objOutlook = CreateObject("Outlook.Application")
     Set objMail = objOutlook.CreateItem(0)

     With Worksheets("Data validation")
         Set rngTo = .Range("J63")
         Set rngSubject = .Range("J61")
         strbody = "One time vendor number request." & vbNewLine & vbNewLine & _
         "Thank you," & vbNewLine & vbNewLine & _
         "__________________________________" & vbNewLine & _
         .Range("J67") & vbNewLine & vbNewLine & _
         "My Company" & vbNewLine & _
         "123 Address street" & vbNewLine & _
         "City, State, Zip, USA" & vbNewLine & _
         "Telephone:"

         End With

     With objMail
         .To = rngTo.Value
         .Subject = rngSubject.Value
         .Body = strbody
         .Save
     End With

     Set objOutlook = Nothing
     Set objMail = Nothing
     Set rngTo = Nothing
     Set rngSubject = Nothing
     Set strbody = Nothing
     Set rngAttach = Nothing

End Sub

Answer 1

你需要的只是：

With objMail
    .To = rngTo.Value
    .Subject = rngSubject.Value
    .Body = strbody
    .attachments.Add Range("F5").Value  'add the attachment
    .Save
End With

使用您的代码，这对我有用。

Answer 2

您好我可以分享以下模板代码，我用它来创建和附加工作簿中的工作表作为PDF _我已经改变了一些＆＃34;文本＆＃34;值，但其余的是相同的。

您可以使用此选项来包含附件，并在需要时以xlsx身份发送。

Sub SendWorkSheetToPDF()

Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim SH As Worksheet

Dim cell As Range
Dim strto As String
Dim Strcc As String

Application.ScreenUpdating = False

'To'
    For Each cell In      ThisWorkbook.Sheets("Mail_addresses").Range("A2:A15")
    If cell.Value Like "?*@?*.?*" Then
        strto = strto & cell.Value & ";"
    End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
On Error Resume Next
'CC'
 For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("B2:B15")
    If cell.Value Like "?*@?*.?*" Then
        Strcc = Strcc & cell.Value & ";"
    End If
Next cell
If Len(Strcc) > 0 Then Strcc = Left(Strcc, Len(Strcc) - 1)
On Error Resume Next

Set Wb = Application.ActiveWorkbook
FileName = "afilename"
xIndex = VBA.InStrRev(FileName, ".")

If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = strto
.CC = Strcc
.BCC = ""
.Subject = "subject text"
.Body = "All," & vbNewLine & vbNewLine & _
    "Please see attached daily " & vbNewLine & vbNewLine & _
    "Kind Regards" & vbNewLine & _
    " "
 .Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
MsgBox "Email Sent"
End Sub

修改电子邮件发送宏以包含附件

2 个答案: