- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello everyone, I have taken some code from these forums and modified it to my needs, but for some reason I don't get, it does work when I use it into one file, but it doesn't work well when I use it in several ("all opened drawings")
It should make the dwg if you chose to, and when going to make the pdfs, determine whether or not each drawing is a multipage or not, and if it is, give you the chance to make a pdf of all the pages, or make a pdf of each page.
Not sure why, when I try it with several drawings, (for example, two with two pages and one with only a page) the outcome is diferent depending on the file I start in, and the dwgs and pdfs are with diferent names, but same content.
I hope you can help me figure out what is wrong with my code.
Sub Main()
Dim myDate As String = Now().ToString("yyyy-MM-dd")
myDate = myDate.Replace(":","") ' & " - " & TypeString
userChoice = InputRadioBox("Elije el alcance", "Este dibujo", "Todos los dibujos abiertos", True, Title := "Elije el alcance")
UserSelectedActionList = New String(){"DWG & PDF", "Solo PDF", "Solo DWG"}
UserSelectedAction = InputListBox("¿Que quieres hacer?", _
UserSelectedActionList, UserSelectedActionList(0), Title := "Archivos a realizar", ListName := "Opciones")
Select UserSelectedAction
Case "DWG & PDF": UserSelectedAction = 3
Case "Solo PDF": UserSelectedAction = 1
Case "Solo DWG": UserSelectedAction = 2
End Select
If userChoice Then
Call MakePDFFromDoc(ThisApplication.ActiveDocument, myDate, UserSelectedAction)
Else
For Each oDoc In ThisApplication.Documents
If oDoc.DocumentType = kDrawingDocumentObject
Try
If Len(oDoc.File.FullFileName)>0 Then
Call MakePDFFromDoc(oDoc, myDate, UserSelectedAction)
End If
Catch
End Try
End If
Next
End If
End Sub
Sub MakePDFFromDoc(ByRef oDocument As Document, DateString As String, UserSelectedAction As Integer)
If (UserSelectedAction = 1) Then
Dim xSheet As Sheet = ActiveSheet.Sheet
Dim xDoc As DrawingDocument = xSheet.Parent
'Convert to list to use IndexOf
'List index starts at 0 while indexes of oDoc.Sheets starts at 1, thats why I add +1
Dim xIndex As Integer = xDoc.Sheets.OfType(Of Sheet).ToList().IndexOf(xSheet) + 1
'Check to see that we got the correct sheet
If xDoc.Sheets(xIndex).Name = "Sheet:1" Then
GoTo multi
Else
End If
go = MsgBox("¿Hacer pdf multipagina?" & vbCrLf & ThisDoc.FileName(False) , MessageBoxButtons.YesNo, "PDF")
If go = vbYes Then
multi :
oPDFAddIn = ThisApplication.ApplicationAddIns.ItemById _
("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
oFullFileName = oDocument.File.FullFileName
oPath = Left(oFullFileName, InStrRev(oFullFileName, "\")-1)
oFileName = Right(oFullFileName, Len(oFullFileName)-InStrRev(oFullFileName, "\"))
oFilePart = Left(oFileName, InStrRev(oFileName, ".")-1)
oOptions.Value("All_Color_AS_Black") = 1
oOptions.Value("Remove_Line_Weights") = 1
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintAllSheets
oFolder = oPath & "\PDFs"
If Not System.IO.Directory.Exists(oFolder) Then
System.IO.Directory.CreateDirectory(oFolder)
End If
oDataMedium.FileName = oFolder & "\" & oFilePart & ".pdf"
oPDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)'For PDF's
GoTo final
Else
oPDFAddIn = ThisApplication.ApplicationAddIns.ItemById _
("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
oFullFileName = oDocument.File.FullFileName
oPath = Left(oFullFileName, InStrRev(oFullFileName, "\")-1)
oFileName = Right(oFullFileName, Len(oFullFileName) -InStrRev(oFullFileName, "\"))
oFilePart = Left(oFileName, InStrRev(oFileName, ".") -1)
oFilename2 = Left(oFileName, Len(oFileName)-4)
oDocument = ThisApplication.ActiveDocument
Dim oDrawing As DrawingDocument
oDrawing = ThisDoc.Document
Dim oSheet As Sheet
Dim lPos As Long
Dim rPos As Long
Dim sLen As Long
Dim sSheetName As String
Dim iSheetNumber As Integer
For Each oSheet In oDrawing.Sheets
lPos = InStr(oSheet.Name, ":")
sLen = Len(oSheet.Name)
sSheetName = Left(oSheet.Name, lPos -1)
iSheetNumber = Right(oSheet.Name, sLen -lPos)
oOptions.Value("All_Color_AS_Black") = 1
oOptions.Value("Remove_Line_Weights") = 1
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintCurrentSheet
oFolder = oPath & "\PDFs"
If Not System.IO.Directory.Exists(oFolder) Then
System.IO.Directory.CreateDirectory(oFolder)
End If
oDataMedium.FileName = oFolder & "\" & oFilename2 & " " & sSheetName & " " & iSheetNumber & ".pdf"
oSheet.Activate
oPDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)'For PDF's
Next
GoTo final
End If
Else If (UserSelectedAction = 2) Then
oPDFAddIn = ThisApplication.ApplicationAddIns.ItemById _
("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
oFullFileName = oDocument.File.FullFileName
oPath = Left(oFullFileName, InStrRev(oFullFileName, "\")-1)
oFileName = Right(oFullFileName, Len(oFullFileName)-InStrRev(oFullFileName, "\"))
oFilePart = Left(oFileName, InStrRev(oFileName, ".")-1)
oOptions.Value("All_Color_AS_Black") = 1
oOptions.Value("Remove_Line_Weights") = 1
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintAllSheets
oFolder = oPath & "\DWGs"
If Not System.IO.Directory.Exists(oFolder) Then
System.IO.Directory.CreateDirectory(oFolder)
End If
oDocument.SaveAs(oFolder & "\" & oFilePart & ".dwg", True) 'For DWG's
GoTo final
Else If (UserSelectedAction = 3) Then
Dim xSheet As Sheet = ActiveSheet.Sheet
Dim xDoc As DrawingDocument = xSheet.Parent
'Convert to list to use IndexOf
'List index starts at 0 while indexes of oDoc.Sheets starts at 1, thats why I add +1
Dim xIndex As Integer = xDoc.Sheets.OfType(Of Sheet).ToList().IndexOf(xSheet) + 1
'Check to see that we got the correct sheet
If xDoc.Sheets(xIndex).Name = "Sheet:1" Then
GoTo multip
Else
End If
go = MsgBox("¿Hacer pdf multipagina?" & vbCrLf & ThisDoc.FileName(False) , MessageBoxButtons.YesNo, "PDF")
If go = vbYes Then
multip:
oPDFAddIn = ThisApplication.ApplicationAddIns.ItemById _
("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
oFullFileName = oDocument.File.FullFileName
oPath = Left(oFullFileName, InStrRev(oFullFileName, "\")-1)
oFileName = Right(oFullFileName, Len(oFullFileName)-InStrRev(oFullFileName, "\"))
oFilePart = Left(oFileName, InStrRev(oFileName, ".")-1)
oOptions.Value("All_Color_AS_Black") = 1
oOptions.Value("Remove_Line_Weights") = 1
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintAllSheets
oFolder = oPath & "\PDFs"
If Not System.IO.Directory.Exists(oFolder) Then
System.IO.Directory.CreateDirectory(oFolder)
End If
oDataMedium.FileName = oFolder & "\" & oFilePart & ".pdf"
oPDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)'For PDF's
GoTo dwgs
Else
oPDFAddIn = ThisApplication.ApplicationAddIns.ItemById _
("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = IOMechanismEnum.kFileBrowseIOMechanism
oOptions = ThisApplication.TransientObjects.CreateNameValueMap
oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
oFullFileName = oDocument.File.FullFileName
oPath = Left(oFullFileName, InStrRev(oFullFileName, "\")-1)
oFileName = Right(oFullFileName, Len(oFullFileName) -InStrRev(oFullFileName, "\"))
oFilePart = Left(oFileName, InStrRev(oFileName, ".") -1)
oFilename2 = Left(oFileName, Len(oFileName)-4)
oDocument = ThisApplication.ActiveDocument
Dim oDrawing As DrawingDocument
oDrawing = ThisDoc.Document
Dim oSheet As Sheet
Dim lPos As Long
Dim rPos As Long
Dim sLen As Long
Dim sSheetName As String
Dim iSheetNumber As Integer
For Each oSheet In oDrawing.Sheets
lPos = InStr(oSheet.Name, ":")
sLen = Len(oSheet.Name)
sSheetName = Left(oSheet.Name, lPos -1)
iSheetNumber = Right(oSheet.Name, sLen -lPos)
oOptions.Value("All_Color_AS_Black") = 1
oOptions.Value("Remove_Line_Weights") = 1
oOptions.Value("Vector_Resolution") = 400
oOptions.Value("Sheet_Range") = Inventor.PrintRangeEnum.kPrintCurrentSheet
oFolder = oPath & "\PDFs"
If Not System.IO.Directory.Exists(oFolder) Then
System.IO.Directory.CreateDirectory(oFolder)
End If
oDataMedium.FileName = oFolder & "\" & oFilename2 & " " & sSheetName & " " & iSheetNumber & ".pdf"
oSheet.Activate
oPDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)'For PDF's
Next
GoTo dwgs
dwgs :
oFolder = oPath & "\DWGs"
If Not System.IO.Directory.Exists(oFolder) Then
System.IO.Directory.CreateDirectory(oFolder)
End If
If (UserSelectedAction = 3) Then
oDocument.SaveAs(oFolder & "\" & oFilePart & ".dwg", True) 'For DWG's
End If
End If
End If
final :
End Sub
Solved! Go to Solution.