Я пытаюсь сгенерировать письма с предложениями, основанные на деталях предоставления и слиянии почты. Но мне нужен вывод в формате PDF вместо слова.
Поскольку он экспортирует файл в формате word, я хочу, чтобы сгенерированный окончательный результат был PDF. Но всякий раз, когда я пытаюсь, я сталкиваюсь с той же ошибкой.
Я получаю Системную ошибку и H80004005 Неуказанная ошибка.
Sub cmdAgree_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.ReferenceStyle = xlA1
' Sheets("DATA").Select
' ActiveSheet.Range("A1").Select
' Selection.End(xlDown).Select
' row_ref = Selection.Row
'
' Sheets("Mail Merge").Range("D4").Value = row_ref
Sheets("Mail Merge").Select
frst_rw = Sheets("Mail Merge").Range("D6").Value
lst_rw = Sheets("Mail Merge").Range("D7").Value
' ActiveWorkbook.Save
'Loop to check if the start row is greater than the last actioned row
If frst_rw = 1 Then
MsgBox "Start row can't be 1. Please check and update to proceed!", vbCritical
Exit Sub
End If
If Sheets("Data").Range("A" & frst_rw).Value = "" Then
MsgBox "No Data to work upon. Please check the reference row used!!!"
Exit Sub
End If
' If frst_rw <= Sheets("Mail Merge").Range("D5").Value And Sheets("Mail Merge").Range("D5").Value <> "" Then
' MsgBox "Start from Row: Cant be less than last actioned row of data in the DATA tab." & vbNewLine _
' & "Please check and update to proceed!", vbCritical
' Exit Sub
' End If
'Loop to check if the last row to generate is greater than the total rows of data
' If lst_rw > Sheets("Mail Merge").Range("D4").Value Then
' MsgBox "End at Row: Cant be greater than total data rows in the DATA tab." & vbNewLine _
' & "Please check and update to proceed!", vbCritical
' Exit Sub
' Else
'Update the last actioned row for future reference
Sheets("Mail Merge").Range("D5").Value = Sheets("Mail Merge").Range("D7").Value
' End If
'Loop though the start row and end row to generate the word documents for different candidates
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
On Error Resume Next
'agreement_folder = ThisWorkbook.Path & "\Agreement Template\"
For x = frst_rw - 1 To lst_rw - 1
' For x = frst_rw To lst_rw
'This if condition tackles the choice of group company basis which the template gets selected
If Sheets("DATA").Range("AS" & x + 1).Value = "APPLE" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - APPLE\"
ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "BANANA" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - BANANA\"
ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "CHERRY" Then
agreement_folder = ThisWorkbook.Path & "\Agreement Template - CHERRY\"
End If
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x + 1).Value)
'Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x).Value)
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `DATA$`"
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = x
.LastRecord = x
End With
.Execute Pause:=False
End With
Dim PathToSave As String
PathToSave = ThisWorkbook.Path & "\" & "pdf" & "\" & Sheets("DATA").Range("B2").Value & ".pdf"
If Dir(PathToSave, 0) <> vbNullString Then
With wd.FileDialog(FileDialogType:=msoFileDialogSaveAs)
If .Show = True Then
PathToSave = .SelectedItems(1)
End If
End With
End If
wd.ActiveDocument.ExportAsFixedFormat PathToSave, 17 'The constant for wdExportFormatPDF
'Sheets("Mail Merge").Select
wd.Visible = True
wdocSource.Close savechanges:=False
wd.ActiveDocument.Close savechanges:=False
Set wdocSource = Nothing
Set wd = Nothing
Next x
Sheets("Mail Merge").Range("D6").ClearContents
Sheets("Mail Merge").Range("D7").ClearContents
MsgBox "All necessary Documents created and are open for your review. Please save and send!", vbCritical
End Sub