I built VBA code to run through a query list of PDF files, open the first file, add some watermark text, save it to a specific path and filename, THEN open each subsequent PDF from the query list sequentially and add watermark text, then insert the watermarked PDF copy into the first saved file. Everything works great when there are only 2-6 pages. I have query lists in the 300+ files (for 400+ pages). The code below fails with Run Time Error 91 at the GETJSObject line. The real head scratcher for me is that this error SEEMS to be speed/processor dependent in that it happens at different times on the same list. Sometimes failing at page 10, sometimes at page 284. Always at the GETJSOBject line (at least that's where the Access VBA shows it failing).
Any suggestions??
Code:
Public Sub PDF_PRINT_HIDDEN(path, parent, TSO, setqty, itemno)
Dim PDFApp As AcroApp
Dim PDFDoc As AcroAVDoc
Dim newPDFDoc As AcroAVDoc
Dim PDDoc As AcroPDDoc
Dim newPDDoc As AcroPDDoc
Dim jso As Object
Dim PDFPath As String
Dim UserID As String
Dim watertxt As String
Dim DisplayPage As Integer
Dim strFirstMatch As String
Dim position As Integer
Dim p1 As String
Dim WasSaved As Variant
UserID = Environ("USERNAME")
PDFPath = "X:\Drawings\"
PDFPath = PDFPath & parent
DisplayPage = 1
Set PDFApp = CreateObject("AcroExch.App")
Set PDFDoc = CreateObject("AcroExch.AVDoc")
Set newPDFDoc = CreateObject("AcroExch.AVDoc")
Set newPDDoc = CreateObject("AcroExch.PDDoc")
If PDFDoc.Open(PDFPath, "") Then
Set PDDoc = PDFDoc.GetPDDoc
'MsgBox parent
'If PDDoc Is Nothing Then
' MsgBox "No PDF Doc to use?"
' MsgBox parent
'End If
'Get JSO object
Set jso = PDDoc.GetJSObject
'Set WaterMark color
Dim color(3) As Variant
color(0) = "RGB"
color(1) = 1
color(2) = 0
color(3) = 0
'Get page size for stamp placement
Dim pdf_Page As Acrobat.AcroPDPage
Dim pg_Size As Object
Dim pg_Rotation As Object
Set pdf_Page = PDDoc.AcquirePage(0)
Set pg_Size = pdf_Page.GetSize
p1 = pg_Size.x / 72
p2 = pg_Size.y / 72
'MsgBox p1
'You have to play with these numbers to get the watermark exactly where you want it
Dim s_X As Double
Dim s_Y As Double
Dim s_Y1 As Double
Dim s_Y2 As Double
Dim s_Angle As Double
Dim num As Integer
If p1 = "8" Then
s_X = 560
s_Y = -325
s_Y1 = -200
s_Y2 = -100
End If
If p1 = "8.5" Then
s_X = 580
s_Y = -325
s_Y1 = -200
s_Y2 = -100
End If
If p1 = "11" Then
s_X = 770
If p2 = "17" Then
s_Y = -525
s_Y1 = -400
s_Y2 = -300
Else
s_Y = -225
s_Y1 = -100
s_Y2 = 0
End If
End If
If p1 = "17" Then
s_X = 1205
If p2 = "22" Then
s_Y = -525
s_Y1 = -400
s_Y2 = -300
Else
s_Y = -325
s_Y1 = -200
s_Y2 = -100
End If
End If
If p1 = "22" Then
s_X = 1560
If p2 = "34" Then
s_Y = -1025
s_Y1 = -900
s_Y2 = -800
Else
s_Y = -525
s_Y1 = -400
s_Y2 = -300
End If
End If
If p1 = "34" Then
s_X = 2410
s_Y = -525
s_Y1 = -400
s_Y2 = -300
End If
s_Angle = 90
'AddWatermarkFromText(cText, nTextAlign, cFont, nFontSize, oColor, nStart, nEnd, bOnTop, bOnScreen, bOnPrint, nHorizAlign, nVertAlign, nHorizValue, nVertValue, bPercentage, nScale, bFixedPrint, nRotation, nOpacity)
Call jso.addWatermarkFromText(TSO, 0, "Helvetica", 16, color, 0, 0, True, True, True, 0, 0, s_X, s_Y, False, 1, False, s_Angle, 0.5)
s_Y = s_Y1
Call jso.addWatermarkFromText(itemno, 0, "Helvetica", 16, color, 0, 0, True, True, True, 0, 0, s_X, s_Y, False, 1, False, s_Angle, 0.5)
s_Y = s_Y2
Call jso.addWatermarkFromText(setqty, 0, "Helvetica", 16, color, 0, 0, True, True, True, 0, 0, s_X, s_Y, False, 1, False, s_Angle, 0.5)
If itemno = "Item #0" Then
WasSaved = PDDoc.Save(PDSaveFull, path)
Call PDFDoc.Close(nosave)
End If
If itemno <> "Item #0" Then
If newPDFDoc.Open(path, "") Then
Set newPDDoc = newPDFDoc.GetPDDoc
num = newPDDoc.GetNumPages - 1
If newPDDoc.InsertPages(num, PDDoc, 0, PDDoc.GetNumPages(), True) = False Then
MsgBox "Cannot insert pages"
End If
If newPDDoc.Save(PDSaveFull, path) = False Then
MsgBox "Cannot save the updated PDF file"
End If
Call PDFDoc.Close(True)
Call newPDFDoc.Close(True)
End If
End If
End If
PDFApp.Exit
Set PDFApp = Nothing
Set PDFDoc = Nothing
Set newPDFDoc = Nothing
Set PDDoc = Nothing
Set newPDDoc = Nothing
Set jso = Nothing
Set pdf_Page = Nothing
Set pg_Size = Nothing
On Error Resume Next
End Sub
4
Replies
AdChoices