MailMerge из Excel и вывод PDF - PullRequest
Новая
       80

MailMerge из Excel и вывод PDF

0 голосов
/ 27 мая 2020

Надеюсь, что там все в безопасности. У меня есть несколько проблем с этим кодом, который я адаптировал снова и снова, и теперь он становится довольно уродливым.

Что я пытаюсь сделать Я генерирую сертификаты через MailMerge, и я хотите, чтобы каждый сертификат сохранялся в формате PDF. У меня есть столбец в источнике, в котором указано имя файла.

Проблема Код останавливается с созданием первого документа. Он не сохраняет его и не включает go. Я возился с вещами, потому что код работал, но я довольно заблокирован с точки зрения безопасности со стороны компании, и поэтому мне приходится щелкать каждый раз, когда он пытается открыть шаблон Word заново. Думаю, не нужно открывать новый шаблон для каждого сертификата. Не закрывайте его, сгенерируйте новый документ, сохраните как PDF и закройте вновь созданный сертификат. - Затем закройте шаблон, как только все сертификаты будут готовы.

Код 

Option Explicit

Public Sub MailMergeCert()

Dim objWord As Word.Application
Dim objMMMD As Word.Document
Dim objTargetDoc As Word.Document


Dim sFirstName As String
Dim sLastName As String
Dim sTrainingTitle As String
Dim sTrainingDate As String
Dim sTrainingLocation As String
Dim sTrainer As String
Dim sTrainerTitle As String
Dim sFileName As String

'On Error GoTo 0
On Error GoTo Err_Handler

'Your Sheet names need to be correct in here
Dim sh1 As Worksheet
    Set sh1 = Sheets("CPD")


' Setup filenames
Const WTempName = "C:\Users\z003uc4z\Documents\Certificates\CPD Certificate New Brand.docx" 'Template name

' Setup directories
Dim cDir As String
Dim ThisFileName As String
cDir = ActiveWorkbook.Path + "\" 'Change if required
ThisFileName = ThisWorkbook.Name

On Error Resume Next

' Create a Word Application instance
            Dim bCreatedWordInstance As Boolean
            Dim WordWasNotRunning As Boolean
            If objWord Is Nothing Then
              Err.Clear
              Set objWord = CreateObject("Word.Application")
              bCreatedWordInstance = True
            End If

            If objWord Is Nothing Then
            MsgBox "Could not start Word"
            Err.Clear
            On Error GoTo 0
            Exit Sub
            End If

' Let Word trap the errors
On Error GoTo 0

' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False

'Open Word Template
Set objMMMD = objWord.Documents.Open(WTempName)
objMMMD.Activate

'Merge the data
With objMMMD
    .MailMerge.OpenDataSource Name:=cDir + ThisFileName, SQLStatement:="SELECT *  FROM `CPD$`"   ' Set this as required


With objMMMD.MailMerge  'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True


Dim r As Long
Dim lastrow As Long
lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row
For r = 61 To lastrow
If IsEmpty(Cells(r, 2).Value) = True Then GoTo nextrow

With .DataSource
  .FirstRecord = r - 1
  .LastRecord = r - 1
  .ActiveRecord = r - 1
End With

.Execute Pause:=False


'Save file as PDF
Dim CertPath As String
        CertPath = ActiveWorkbook.Path & "\CPDCerts\2020"
Dim NewFileNamePDF As String
        NewFileNamePDF = sFileName
        Set objTargetDoc = ActiveDocument
            objTargetDoc.ExportAsFixedFormat CertPath & NewFileNamePDF, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False
            objTargetDoc.Close False

    sh1.Cells(r, 1).Value = "x"
    objMMMD.Close False


' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject("", "Word.Application")
' Close the New Mail Merged Document
If bCreatedWordInstance Then
objWord.Quit
End If




nextrow:
Next r



0:
Set objWord = Nothing

End With
End With

Exit Sub

Err_Handler:
    MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " _
            & Err.Number
    If WordWasNotRunning Then
        objWord.Quit
    End If

End Sub

Любые указания, как я могу очистить код и запустить его, были бы очень очень признателен. Спасибо, Кристина

...