我制作了代码(如下所示),可以通过电子邮件正确发送一份PDF,但我需要再发送一份PDF。
Dim varFindThis As Variant
Dim rngLookIn As Range
varFindThis = Worksheets("Suivi").Range("B1")
Set rngLookIn = Worksheets("Suivi").Range("A:A")
If Not rngLookIn.Find(varFindThis, LookIn:=xlValues) Is Nothing Then
Dim f As String
f = Worksheets("Suivi").Range("B1").Value
'Since i didn't got that clear, here above you must create a code to declare "f" as whatever you want
Set c = Worksheets("Suivi").Range("A:A").Find(f)
Worksheets("Suivi").Range(c.Address).EntireRow.Delete
End If
'Do not forget to change the email ID
'before running this code
Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
' With Application
' .ScreenUpdating = False
' .EnableEvents = False
' End With
Application.DisplayFullScreen = False
ThisWorkbook.Worksheets("PDF").Activate
Range("B1:BG46").Select
ActiveSheet.PageSetup.PrintArea = "$B$1:$BG$46"
' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.
TempFilePath = Environ$("temp") & "\"
' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.
TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-20yy") & ".pdf"
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
'Now Export the Activesshet as PDF with the given File Name and path
On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
'Now open a new mail
Set OlApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In ThisWorkbook.Sheets("Envoie").Columns("C").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next
For Each cell In ThisWorkbook.Sheets("Envoie").Columns("G").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
Next
Subj = "N°Article" & ThisWorkbook.Sheets("CalculInfo").Range("A10")
Set NewMail = OlApp.CreateItem(0)
On Error Resume Next
With NewMail
.To = EmailAddr1
.CC = EmailAddr2
.BCC = "gaetan.affolter@he-arc.ch"
.Subject = Subj
.Body = "Bonjour, il vous reste 24 heures pour vérifier les données du PDF et de confirmer dans Octopus. Merci"
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.Send 'or use .Display to show you the email before sending it.
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder
Kill FileFullPath
'set nothing to the objects created
Set NewMail = Nothing
Set OlApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Email a été envoyé")
Exit Sub
err:
MsgBox err.Description
Unload Me
PrintArea我位于工作表(“CalcGammeControle”),更准确地说是“$ G $ 2:$ G $ 35”
如何添加?