来自Inventor VBA的PDF打印
嗨，伙计们，我意识到这与发明家有关，所以请随时将这篇文章移动到需要去的地方。（如果确实有别的地方可以让它去，那就是？无论出于何种原因，我们的客户无法查看由 Inventor 2009 中的本机 pdf 打印机创建的 pdf，因此我不得不想出一种使用 PDFCreator 打印 DrawingDocument （DrawDoc） 内容的方法。
根据安装最新软件包时提供的示例，我拼凑了以下似乎有效的代码，但由于某种原因，我几乎永远无法让它从DrawDoc打印第一页。
我认为问题在于PDFCreator是如何初始化的，但我似乎无法弄清楚，并认为也许你们中的一个人可以帮助我。
这是代码： -
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("", 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)"" 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)"" symbol
' and to the left of the last ""))
GetPromptField = Left$(GetPromptField, InStr(GetPromptField, " withsymbols.
GetPromptField = Replace(GetPromptField, "", ">")
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
另外，理想情况下，我想从IV2009中的工具栏运行它 - 有人可以提供一个如何实现这一点的示例吗？
谢谢。
**** Hidden Message *****
页:
[1]