Hello - I have the same issue. Would greatly appreciate any help. Thank you!
'this rule outputs all drawing sheets to PDF
'this rule outputs all drawing sheets to DWF, 3D models of first sheet included
Public Sub Main()
'Ask to print file
printerName = "\\JLF-PRINT01\Canon Meadow Lighting_Dept PS3"
askprint = MessageBox.Show("Print to " & printerName & "?", "Print",MessageBoxButtons.YesNoCancel)
If askprint = vbYes
Dim oDrawDoc As Document
oDrawDoc = ThisApplication.ActiveDocument
Dim oPrintMgr As PrintManager
oPrintMgr = oDrawDoc.PrintManager
'specify your printer name
'\\JLF-PRINT01\Canon Meadow Lighting_Dept PS3
oPrintMgr.Printer = printerName
oPrintMgr.PrintRange = Inventor.PrintRangeEnum.kPrintAllSheets
oPrintMgr.ColorMode = PrintColorModeEnum.kPrintGrayScale
oPrintMgr.AllColorsAsBlack = False
oPrintMgr.Orientation = PrintOrientationEnum.kPortraitOrientation
oPrintMgr.PaperSize = SizeActiveSheet
oPrintMgr.SubmitPrint
Else If askprint = vbCancel
Goto ErrorHandle
End If
'Set-Up declarations for DPF and DWF add-ins
PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
DWFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oDocument = ThisApplication.ActiveDocument
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
PDFOptions = ThisApplication.TransientObjects.CreateNameValueMap
DWFOptions = ThisApplication.TransientObjects.CreateNameValueMap
PDFOptions = ThisApplication.TransientObjects.CreateDataMedium
DWFOptions = ThisApplication.TransientObjects.CreateDataMedium
'Define the save path
Dim fileName As String
filename = ThisDoc.FileName(True)
Prefix = Left(fileName, 3) 'First 3 characters i.e. "803"
FirstSpace = InStr(1, fileName, " ") 'Gets location in strine of the first space
If Not FirstSpace = 0
PartNumber = Left(fileName, FirstSpace-1) 'Assign everything left of the space to part number
Else 'There is no space
dot = InStr(1, fileName, ".") 'Gets the location in string of the first "."
PartNumber = Left(fileName, dot-1) 'Assign everything left of the "." to part number
End If
'PartNumber = Left(fileName, 9) 'Full Part number i.e. "803-00044"
'last5 = Right(DNumber, 5) 'Last 5 characters i.e. "00044"
'Image Library folder names have additional descriptors...
If Left(Prefix, 3) = "801"
folderDescription = "Table Lamps"
Else If Left(Prefix, 3) = "802"
folderDescription = "Floor Lamps"
Else If Left(Prefix, 3) = "803"
folderDescription = "Wall Lamps"
Else If Left(Prefix, 3) = "804"
folderDescription = "Ceiling Lamps"
Else If Left(Prefix, 3) = "809"
folderDescription = "Shades"
End If
PDF_Path = "I:\" & Prefix & " - " & folderDescription & "\PDF"
DWF_Path = "I:\" & Prefix & " - " & folderDescription & "\DWF"
'Create PDF file
PDF_File_Name = PartNumber & "-" & iProperties.Value("Project", "Project") & ".pdf"
'Debug line to show PDF save path
'MessageBox.Show(PDF_PATH, "PDF Save Path")
If PDFAddIn.HasSaveCopyAsOptions(PDFDataMedium, oContext, PDFOptions) Then
PDFOptions.Value("All_Color_AS_Black") = 0
PDFOptions.Value("Remove_Line_Weights") = 0
PDFOptions.Value("Vector_Resolution") = 4800
PDFOptions.Value("Gradient_Resolution") = 4800
PDFOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintAllSheets
'PDFOptions.Value("Custom_Begin_Sheet") = 2
'PDFOptions.Value("Custom_End_Sheet") = 4
End If
'Set the PDF target file name
'Shop Drawing
If ActiveSheet.TitleBlock = "MEADOW SHOP TITLE BLOCK"
Cloc = InStr(1, fileName, "C") 'Gets location in string of the "C"
If Cloc = 0
MFG_Folder = PartNumber & "-C" 'Add "-C" to PartNumber
PDF_File_Name = ThisDoc.FileName(False) & ".pdf"
Else
MFG_Folder = Left(PartNumber, Cloc) 'Crop the end of Shop Drawing Part Number to the "C"
PDF_File_Name = PartNumber & ".pdf"
End If
Shop_PDF_Path = PDF_Path & "\MFG DRAWINGS\" & MFG_Folder
PDFDataMedium.FileName = Shop_PDF_Path & "\" & PDF_File_Name
'MessageBox.Show(Shop_PDF_PATH, "PDF Save Path")
Else
'MessageBox.Show(PDF_PATH, "PDF Save Path")
PDFDataMedium.FileName = PDF_Path & "\" & PDF_File_Name
End If
'Publish PDF document
Try
PDFAddIn.SaveCopyAs(oDocument, oContext, PDFOptions, PDFDataMedium)
Catch
MessageBox.Show("Error - PDF may be open in another viewer, or destination folder does not exist.", "Problem saving PDF to P", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
If ActiveSheet.TitleBlock = "MEADOW SALES TITLE BLOCK" 'Sales Drawing
'Publish copy with Rev info in Project Directory
copy_Path = ThisDoc.Path & "/" & PartNumber & " DOCS"
copy_FileName = PartNumber & "-" & iProperties.Value("Project", "Project") & " Rev " & iProperties.Value("Project", "Revision Number") & ".pdf"
PDFDataMedium.FileName = copy_Path & "\" & copy_FileName
PDFAddIn.SaveCopyAs(oDocument, oContext, PDFOptions, PDFDataMedium)
'Create DWF file
'Store and delete Project, Side Mark, & Quantity
storeProject = iProperties.Value("Project", "Project")
storeSideMark = iProperties.Value("Custom", "SIDEMARK")
storeQuantity = iProperties.Value("Custom", "QUANTITY")
iProperties.Value("Project", "Project") = ""
iProperties.Value("Custom", "SIDEMARK") = ""
iProperties.Value("Custom", "QUANTITY") = ""
InventorVb.DocumentUpdate()
DWF_File_Name = PartNumber & ".dwf"
'Debug line to show DWF save path
'MessageBox.Show(DWF_PATH, "DWF Save Path"
'askview = MessageBox.Show("Launch the DWF Viewer now?", "Launch DWF Viewer",MessageBoxButtons.YesNo)
'If askview = vbYes Then : launchviewer = 1 : Else : launchviewer = 0 : End IF
launchviewer = 0
If DWFAddIn.HasSaveACopyAsOptions(DWFDataMedium, oContext, DWFOptions)Then
DWFOptions.Value("Launch_Viewer") = launchviewer
DWFOptions.Value("Publish_All_Component_Props") = 1
DWFOptions.Value("Publish_All_Physical_Props") = 1
DWFOptions.Value("Password") = 0
DWFOptions.Value("Publish_3D_Models") = Publish_3D_Models
If TypeOf oDocument Is DrawingDocument Then
Dim oSheets As NameValueMap
oSheets = ThisApplication.TransientObjects.CreateNameValueMap
DWFOptions.Value("Publish_Mode") = DWFPublishModeEnum.kCompleteDWFPublish
DWFOptions.Value("Publish_All_Sheets") = 1
'Publish the first sheet AND its 3D model
Dim oSheet1Options As NameValueMap
oSheet1Options = ThisApplication.TransientObjects.CreateNameValueMap
oSheet1Options.Add("Name", "Sheet:1")
oSheet1Options.Add("3DModel", True)
oSheets.Value("Sheet1") = oSheetOptions
End If
End If
DWFDataMedium.FileName = DWF_PATH & "\" & DWF_File_Name
Try
Call DWFAddin.SaveCopyAs(oDocument, oContext, DWFOptions, DWFDataMedium)
Catch
MessageBox.Show("Error - DWF may be open in another viewer, or destination folder does not exist.", "Problem saving to DWF to P",
MessageBoxButtons.OK, MessageBoxIcon.Error)
'Restore Project, Side Mark, Quantity fields
iProperties.Value("Project", "Project") = storeProject
iProperties.Value("Custom", "SIDE MARK") = storeSideMark
iProperties.Value("Custom", "QUANTITY") = storeQuantity
InventorVb.DocumentUpdate()
End Try
If launchviewer = 1 Then ThisDoc.Launch(DWF_PATH & "\" & DWF_File_Name)
'Export copy to project directory
copy_Path = ThisDoc.Path & "\" & PartNumber & " DOCS"
copy_FileName = PartNumber & " REV " & iProperties.Value("Project", "Revision Number") & ".dwf"
DWFOptions.Value("Launch_Viewer") = 0 'Dont launch viewer for the copy
DWFDataMedium.FileName = copy_Path & "\" & copy_FileName
Call DWFAddIn.SaveCopyAs(oDocument, oContext, DWFOptions, DWFDataMedium)
'Restore Project, Side Mark, Quantity Fields
iProperties.Value("Project", "Project") = storeProject
iProperties.Value("Custom", "SIDE MARK") = storeSideMark
iProperties.Value("Custom", "QUANTITY") = storeQuantity
InventorVb.DocumentUpdate()
ErrorHandle:
If OldDrawing = 1
MessageBox.Show("Unable to remove Project information - old Title Block format", "Error", MessageBoxButtons.OK, MessageBoxIcon.Warning)
End If
End If
End Sub