时间戳

首页 > 解决方案 > 打印为 PDF 时从 Excel 工作表重命名 Word 宏

vba - 打印为 PDF 时从 Excel 工作表重命名 Word 宏

问题描述

我已经设置了一个邮件合并，以根据 Excel 表的输入草稿信件。后草稿完成。我有 Word VBA 代码将每一页打印为 PDF。目前它要求我保存文件夹和文件名以手动输入。如何在下面的代码中合并要从 excelsheet 中选择的文件夹位置和文件名：

Sub Print_letter()
Dim x As Long, StrPrtr As String
StrPrtr = Application.ActivePrinter
Application.ActivePrinter = "microsoft print to pdf"
With ActiveDocument
  For x = 1 To .ComputeStatistics(wdStatisticPages)
    Application.PrintOut PrintToFile:=False, FileName:="", _
      Range:=wdPrintRangeOfPages, Pages:=CStr(x), Item:=wdPrintDocumentWithMarkup, _
      Background:=True, PageType:=wdPrintAllPages, Copies:=1, Collate:=False, _
      PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, PrintZoomPaperHeight:=0
  Next x
End With
Application.ActivePrinter = StrPrtr
End Sub

标签： vbams-word

解决方案

你什么都不说，我必须离开我的办公室......

请尝试下一个能够定义 Excel 工作簿范围的代码：

'It needs a reference to 'Microsoft Excel ... Object library'
Function getRangefromExcelSession(strWorkbook As String, strSheet As String) As Excel.Range
  Dim Ex As Excel.Application, ws As Worksheet, wb As Workbook, rng As Range
  Dim wbFound As Workbook, Boolfound As Boolean, lastRow As Long
  
   On Error Resume Next
    Set Ex = GetObject(, "Excel.Application")
     If Err.Number = 0 Then
        Err.Clear: On Error GoTo 0
        For Each wb In Ex.Workbooks
            If wb.Name = strWorkbook Then
                Set wbFound = wb
                Boolfound = True
            End If
        Next
     Else
       On Error GoTo 0
       MsgBox "There is not any Excel session open...", vbInformation, "Ups...": Exit Function
     End If
     If Boolfound Then
        Set ws = wbFound.Worksheets(strSheet)
        lastRow = ws.Range("F" & ws.Rows.count).End(xlUp).row
        Set getRangefromExcelSession = ws.Range("F2:F" & lastRow)
     End If
End Function

如果找不到（您的）工作簿/工作表，则不提供错误处理...

可以通过这种方式获得必要的范围：

Sub testBetRangeFromExcelSess()
    Dim rng As Excel.Range, cel As Range
    Set rng = getRangefromExcelSession("Your workbook name", "Your sheet name")
    If Not rng Is Nothing Then
        Debug.Print rng.Address
        For Each cel In rng
            Debug.Print cel.Value
        Next
    End IfWindow
End Sub

编辑：

您修改后的代码应如下所示：

Sub Print_letter()
Dim x As Long, StrPrtr As String
StrPrtr = Application.ActivePrinter
Application.ActivePrinter = "microsoft print to pdf"

Dim rng As Excel.Range
Set rng = getRangefromExcelSession("Workbook name", "sheet name")

With ActiveDocument
  For x = 1 To .BuiltInDocumentProperties("Number of Pages")
    Application.PrintOut PrintToFile:=False, OutputFileName:="C:\" & rng(x, 1).Value & ".pdf", _
      Range:=wdPrintRangeOfPages, Pages:=CStr(x), Item:=wdPrintDocumentWithMarkup, _
      background:=True, PageType:=wdPrintAllPages, Copies:=1, Collate:=False, _
      PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, PrintZoomPaperHeight:=0
  Next x
End With
Application.ActivePrinter = StrPrtr
End Sub

第二次编辑：

请尝试运行下一个测试代码：

Sub testPrintToPdf_() 
 Dim StrPrtr As String, x As Long
 StrPrtr = Application.ActivePrinter
 Application.ActivePrinter = "microsoft print to pdf"
 
 With ActiveDocument
    For x = 1 To .BuiltInDocumentProperties("Number of Pages")
        Application.PrintOut PrintToFile:=False, OutputFileName:="C:\testdDoc_" & x & ".pdf", _
          Range:=wdPrintRangeOfPages, Pages:=CStr(x), Item:=wdPrintDocumentWithMarkup, _
          Background:=True, PageType:=wdPrintAllPages, Copies:=1, Collate:=False, _
          PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, PrintZoomPaperHeight:=0
    Next x
 End With
End Sub

它应该返回 15 个名为“testDoc_1,pdf”、“testDoc_2,pdf”等的文档......

推荐阅读