Question

我研究了以下代码，该代码制作了一个工作表的副本，然后将其从无用的数据中清除出来，然后将新工作表的“已用范围”导出到PDf，最后创建了一个以PDF为附件的电子邮件。 / p>

除一件“小”事情外，一切都正常。我无法“个性化” PDF文件的名称。我的目标是自动创建一个带有客户名称的文件名以及从原始工作表获取的其他信息。请您让我了解我在哪里犯错，以及如何解决这个问题？当然，可以优化该代码（实际上，例程有些慢），但可能在解决此问题之后;-）

这是代码

Sub ExportToPDFAndEmail()
Dim yFileDlg As FileDialog
Dim yFolder As String
Dim yYesorNo As Integer
Dim yOutlookObj As Object
Dim yEmailObj As Object
Dim NomeCliente, Subj, Email As String

Set yFileDlg = Application.FileDialog(msoFileDialogFolderPicker)


'Copies and pastes a copy of TEMPLATE Worksheet, then it cleans the new Sheet up from unsuseful data _
'and blank rows in the description column, finally it deletes some columns
Application.ScreenUpdating = False
    Sheets("TEMPLATE").Select
    Sheets("TEMPLATE").Copy Before:=Sheets(1)
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.Delete
    Range("F9").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeFormulas, 16).Select
    Selection.EntireRow.Delete
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("F:Z").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("B2").Select

'User can choose Folder and filename to save PDF
If yFileDlg.Show = True Then
   yFolder = yFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "You must specify destination folder."
   Application.DisplayAlerts = False
   ActiveSheet.Delete
   Application.DisplayAlerts = True
   Exit Sub
End If

PDFname = Worksheets("TEMPLATE").Range("J1").Value
yFolder = yFolder + "\" + "Sollecito al " + ".pdf"

'Checks if file already exists
If Len(Dir(yFolder)) > 0 Then
    yYesorNo = MsgBox(yFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If yYesorNo = vbYes Then
        Kill yFolder
    Else
        MsgBox "If you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to delete the file"
        Exit Sub
    End If
End If

s = Worksheets("TEMPLATE").Range("X2").Value
NomeCliente = Worksheets("TEMPLATE").Range("B3").Value
Email = Worksheets("TEMPLATE").Range("D4").Value
Subj = Worksheets("TEMPLATE").Range("X2").Value
MesgBefore = Worksheets("TEMPLATE").Range("X3").Value
MesgAfter = Worksheets("TEMPLATE").Range("X6").Value
MesgBefore = Replace(Replace(MesgBefore, "#NomeCliente#", NomeCliente), Chr(10), "<br>")
MesgAfter = Replace(Replace(MesgAfter, "#NomeCliente#", NomeCliente), Chr(10), "<br>")


Set rng = ActiveSheet.UsedRange
ActiveSheet.PageSetup.PrintArea = rng.Address
With ActiveSheet.PageSetup
        .PrintTitleRows = "$2:$8"
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 6
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With

'Exports to PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, fileName:=yFolder, Quality:=xlQualityStandard

'Creates Outlook Email
Set yOutlookObj = CreateObject("Outlook.Application")
Set yEmailObj = yOutlookObj.CreateItem(0)
    With yEmailObj
        .To = Email
        .CC = ""
        On Error Resume Next
        .Attachments.Add yFolder
        On Error GoTo 0
        .Subject = s
        .HTMLBody = .HTMLBody & "<br>" & MesgBefore & "<br><br>" & MesgAfter & "</font></span>"
        .Display
    End With
On Error GoTo 0
Set yEmailObj = Nothing
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

我希望PDF的名称作为J1中的值。

PDFname = Worksheets("TEMPLATE").Range("J1").Value

但是，如果我在yFolder中添加PDFname，则例程将返回错误。

你能帮我吗？

Answer 1

我对vba有点陌生，正在通过手机查看它，因此，如果我走了，请原谅我，但我想尝试提供帮助。您是否需要将pdfname调暗？我从未将其视为已声明的变量，但是我还是在手机上再次查看它，因此很容易错过了它

EXCEL VBA-将工作表导出为PDF并作为附件通过电子邮件发送

1 个答案: