TheSwamp

Code Red => VB(A) => Topic started by: vegbruiser on August 03, 2009, 09:45:14 AM

Title: PDF Printing from Inventor VBA
Post by: vegbruiser on August 03, 2009, 09:45:14 AM

Hi folks, I realise this is Inventor related so please feel free to move this post to wherever it needs to go. (If there is indeed somewhere else for it to go that is?)

For whatever reason, our client can't view pdfs created by the native pdf printer in Inventor 2009, so I had to come up with a method of printing the contents of the DrawingDocument (DrawDoc) using PDFCreator (http://www.pdfforge.org/products/pdfcreator).

I have cobbled together the following code that seems to work, based on the examples that are provided upon installation of the latest package, yet for some reason I can almost never get it to print the first page from the DrawDoc.

I think the problem lies with how the PDFCreator is initialized, but I can't seem to figure it out and thought perhaps one of you might be able to help me.

Here's the code: -

Code: [Select]

Option Explicit

Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Public tmpstr As String
Public revisions(8, 4) As String ' 10 is the maximum number of revisions the border can have
' Add a reference to PDFCreator
Public pdfcreator1 As PDFCreator.clsPDFCreator
Public ReadyState As Boolean
Public DefaultPrinter As String
Public ProjectLocation As String
Public ProjectName As String
Public Project As String
Public pErr As PDFCreator.clsPDFCreatorError
Public StartTime As Date

Public Sub PlotPdf()

Dim killit
Dim numsheets As Integer
Dim parameters As String

Set pErr = New PDFCreator.clsPDFCreatorError
Set pdfcreator1 = New clsPDFCreator
pdfcreator1.cPrinterStop = False
pdfcreator1.cVisible = True
numsheets = 0

If ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
With pdfcreator1
    .cVisible = True
    parameters = "/NoProcessingAtStartup"
    If .cStart(parameters) = False Then
        If .cStart(parameters, True) = False Then
            .cClearCache
            .cOption("UseAutoSave") = 0
        
            ' killit = Shell("taskkill /f /im PDFCreator.exe", VbAppWinStyle.vbHide)
            ' MsgBox ("There was an error starting the pdf printer, please try (click) again!")
            ' Debug.Print "Can't initialize PDFCreator."
            ' Exit Sub
        End If
        AddStatus "Use an existing running instance!"
        .cVisible = True
    End If
End With

    ' Debug.Print "PDFCreator initialized."

Dim oDrgDoc As DrawingDocument

Set oDrgDoc = ThisApplication.ActiveDocument
UserForm1.ComboBox1.AddItem ("Aliquot")
' UserForm1.ComboBox1.AddItem ("EDD")
UserForm1.Show

' Set reference to drawing print manager
Dim oDrgPrintMgr As DrawingPrintManager
Set oDrgPrintMgr = oDrgDoc.PrintManager

' Set the printer name
oDrgPrintMgr.Printer = "PDFCreator"


Dim shts As sheets
Dim sht As sheet
Dim outName As String
Dim i As Integer
Dim j As Integer
Dim Latestrev As Integer
Dim sheetsize As PaperSizeEnum
sheetsize = kPaperSizeA0
sheetsize = kPaperSizeA1
' shts = oDrgDoc.sheets

For Each sht In oDrgDoc.sheets
    sht.Activate
    'Set the paper size , scale and orientation
    oDrgPrintMgr.ScaleMode = kPrintFullScale ' kPrintBestFitScale
    ' Change the paper size to a custom size. The units are in centimeters.
    Dim shtsize As Long
    shtsize = sht.Size
    oDrgPrintMgr.PaperSize = kPaperSizeCustom
    If shtsize = 9993 Then ' A0
        oDrgPrintMgr.PaperHeight = 84.1
        oDrgPrintMgr.PaperWidth = 118.9
    ElseIf shtsize = 9994 Then ' A1
        oDrgPrintMgr.PaperHeight = 59.4
        oDrgPrintMgr.PaperWidth = 84.1
    ElseIf shtsize = 9995 Then ' A2
        oDrgPrintMgr.PaperHeight = 42
        oDrgPrintMgr.PaperWidth = 59.4
    ElseIf shtsize = 9996 Then ' A3
        oDrgPrintMgr.PaperHeight = 29.7
        oDrgPrintMgr.PaperWidth = 42
    End If
    oDrgPrintMgr.PrintRange = kPrintCurrentSheet
    oDrgPrintMgr.Orientation = kLandscapeOrientation
    oDrgPrintMgr.AllColorsAsBlack = False
    oDrgPrintMgr.Rotate90Degrees = True
        
    Latestrev = RetrieveRev
    
    outName = RetrievePE("<Drawing Number>", sht) & " REV " & Latestrev & ".pdf"
    With pdfcreator1
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = "\\bas059\Aliquot\pdfs\" ' Project
        .cOption("AutosaveFilename") = outName
        .cOption("AutosaveFormat") = 0                            ' 0 = PDF
        .cClearCache
    End With

    oDrgPrintMgr.SubmitPrint
    StartTime = Now
    Do Until pdfcreator1.cCountOfPrintjobs = 1
    DoEvents
        Sleep 1000
    Loop
    Sleep 1000
    pdfcreator1.cPrinterStop = False
    For i = 1 To 8
        For j = 1 To 4
            revisions(i, j) = ""
        Next j
    Next i
    numsheets = numsheets + 1
    AddStatus pdfcreator1.cOutputFilename & " was created! (" & _
  DateDiff("s", StartTime, Now) & " seconds)"
Next
Else
    MsgBox ("You aren't using an Inventor drawing!")
    Exit Sub
End If
MsgBox ("Done Printing " & numsheets & " sheets!")
 pdfcreator1.cClose
 killit = Shell("taskkill /f /im PDFCreator.exe", VbAppWinStyle.vbHide)
End Sub
'--- the code hereafter is simply for populating the filename with the correct information/ setting the sheetsize etc.

Public Function Setsheetsize(shtsize As PaperSizeEnum) As PaperSizeEnum
If shtsize = 9993 Then
    Setsheetsize = kPaperSizeA0
ElseIf shtsize = 9994 Then
    Setsheetsize = kPaperSizeA1
ElseIf shtsize = 9995 Then
    Setsheetsize = kPaperSizeA2
ElseIf shtsize = 9996 Then
    Setsheetsize = kPaperSizeA3
End If
End Function

Public Function RetrievePE(searchstring As String, oSheet As sheet) As String
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
' Dim oSheet As sheet
' Set oSheet = oDrawDoc.ActiveSheet

' Get the prompted text value from the title block.
' This is done by first getting the text box in the title
' block definition that defines the prompted text.  Then
' you can use this to get the value specified for this
' particular title block instance.

Dim oBorderDef As BorderDefinition

Set oBorderDef = oSheet.Border.Definition

Dim oTextBox As TextBox
Dim bFound As Boolean
bFound = False
For Each oTextBox In oBorderDef.Sketch.TextBoxes
    If GetPromptField(oTextBox.FormattedText) = searchstring Then
        bFound = True
        Exit For
    End If
Next
If bFound Then
    ' oSheet.Name = oSheet.Border.GetResultText(oTextBox)
    RetrievePE = oSheet.Border.GetResultText(oTextBox)
Else
    MsgBox "Specified formatted text was not found in the title block."
End If

End Function

Public Function RetrieveRev() As Integer ' will only work whilst the revision is numeric!
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
Dim oSheet As sheet
Set oSheet = oDrawDoc.ActiveSheet

Dim oBorderDef As BorderDefinition

Set oBorderDef = oSheet.Border.Definition

Dim oTextBox As TextBox
Dim bFound As Boolean
bFound = False
Dim Revision As String
Dim cnt As Integer

Dim i As Integer
Dim j As Integer
i = 1
cnt = 0
For Each oTextBox In oBorderDef.Sketch.TextBoxes
    Revision = GetPromptField(oTextBox.FormattedText)
    If Revision Like "*REV*" Then
        If Revision Like "*REV*Change*" Or Revision Like "*REV*CHANGE*" Then
            revisions(i, 1) = oSheet.Border.GetResultText(oTextBox) ' Change
            cnt = cnt + 1
        ElseIf Revision Like "*REV*Date*" Or Revision Like "*REV*DATE*" Then
            revisions(i, 3) = oSheet.Border.GetResultText(oTextBox) ' Date
            cnt = cnt + 1
        ElseIf Revision Like "*REV*" And Len(Revision) < 13 Then
            revisions(i, 2) = oSheet.Border.GetResultText(oTextBox) ' Rev
            cnt = cnt + 1
        End If
            revisions(i, 4) = oSheet.Name
        If cnt = 3 Then
            cnt = 0
            i = i + 1
        End If
    End If
Next

For i = LBound(revisions) To UBound(revisions)
    If revisions(i, 1) <> "" Then
        ' Debug.Print revisions(i, 1) & "|" & revisions(i, 2) & "|" & revisions(i, 3)
    End If
Next i
Bubblesort
For i = LBound(revisions) To UBound(revisions)
    If revisions(i, 1) <> "" Then
        ' Debug.Print revisions(i, 1) & "|" & revisions(i, 2) & "|" & revisions(i, 3)
    End If
Next i
For i = LBound(revisions) To UBound(revisions)
    If revisions(i, 2) <> "" Then
        RetrieveRev = revisions(i, 2)
        If revisions(i + 1, 2) = "" Then ' we reached the highest revision.
            Exit For
        End If
    End If
Next i

End Function

' Get the text value of the prompted text.  It extracts this from the' formatted text.  If there's a failure then an empty string is =returned.

Private Function GetPromptField(ByVal FormattedText As String) As String

On Error GoTo ErrorFound

' Verify that this is a prompt field.
If Left$(FormattedText, 7) <> "<Prompt" Then
    GetPromptField = ""
    Exit Function
End If
' Get the text that is to the right of the first ">" symbol
' and to the left of the last "<" symbol.
' Debug.Print FormattedText
GetPromptField = Right$(FormattedText, Len(FormattedText) - InStr(FormattedText, ">"))
GetPromptField = Left$(GetPromptField, InStr(GetPromptField, "<") - 1)
' Replace any &lt; or &gt; with < and > symbols.
GetPromptField = Replace(GetPromptField, "&lt;", "<")
GetPromptField = Replace(GetPromptField, "&gt;", ">")
Exit Function
ErrorFound:    GetPromptField = ""

End Function


Public Sub Bubblesort()
Dim i As Integer
Dim j As Integer
Dim temp As String
Dim iOuter As Long
Dim iInner As Long
Dim iLbound As Long
Dim iUbound As Long
Dim iTemp As String
 
iLbound = LBound(revisions)
For i = iLbound To UBound(revisions) ' - 1
    If revisions(i, 2) <> "" Then
        iUbound = i
    End If
Next i
 
For iOuter = iLbound To iUbound ' - 1
        'Which comparison
        For iInner = iLbound To iUbound - iOuter - 1
            'Compare this item to the next item
            If revisions(iInner, 2) <> "" Then ' Continue
                ' Debug.Print "About to sort " & revisions(iInner, 4)
                If CInt(revisions(iInner, 2)) > CInt(revisions(iInner + 1, 2)) Then
                    'Swap
                    iTemp = revisions(iInner, 1)
                    revisions(iInner, 1) = revisions(iInner + 1, 1)
                    revisions(iInner + 1, 1) = iTemp
                    iTemp = revisions(iInner, 2)
                    revisions(iInner, 2) = revisions(iInner + 1, 2)
                    revisions(iInner + 1, 2) = iTemp
                    iTemp = revisions(iInner, 3)
                    revisions(iInner, 3) = revisions(iInner + 1, 3)
                    revisions(iInner + 1, 3) = iTemp
                    iTemp = revisions(iInner, 4)
                    revisions(iInner, 4) = revisions(iInner + 1, 4)
                    revisions(iInner + 1, 4) = iTemp
                End If
            End If
        Next iInner
    Next iOuter
 
' MsgBox ("Done Sorting!")
End Sub


Private Sub PrintPage(PageNumber As Integer)
 Dim cPages As Long
 cPages = Selection.Information(wdNumberOfPagesInDocument)
 If PageNumber > cPages Then
  MsgBox "This document has only " & cPages & " pages!", vbExclamation
 End If
 DoEvents
 ActiveDocument.PrintOut Background:=False, Range:=wdPrintFromTo, From:=CStr(PageNumber), To:=CStr(PageNumber)
 DoEvents
End Sub

Private Sub PDFCreator1_eError()
pErr = pdfcreator1.cError
AddStatus ("Status: Error[" & pErr.Number & "]: " & pErr.Description)
End Sub

Private Sub PDFCreator1_eReady()
 AddStatus "File'" & pdfcreator1.cOutputFilename & "' was saved."
 pdfcreator1.cPrinterStop = True
 ' CommandButton1.Enabled = True
End Sub

Private Sub AddStatus(Str1 As String)
    Debug.Print vbCrLf & Now & ": " & Str1
End Sub


Also, I would ideally like to run this from a toolbar within IV2009 - can someone please provide an example of how to accomplish this?

Thanks.