It's been a while since anyone has posted in here, BUT...
I've uploaded a program I slapped together that "exports all sheets into 1 model space"
- It creates a folder and subfolder for all the work that will follow
- A Subfolder that contains all the exported sheets to their respective Model Space ACAD Files
- It creates a master ACAD File
- It copies all the other files into the master file and places them nice and organized like.
- Everything is copied and pasted to 1:1 scale in model space
- It creates Layouts tabs for all the generated sheets in the master file.
BEFORE YOU TRY IT, SAVE YOUR EXPORT SETTINGS TO AN INI FILE
https://help.autodesk.com/sfdcarticles/img/0EM30000001HyXH
Change line 48,
strIniFile = "C:\TheFolderPathThatContainsThisFile\ACAD_Drawing_Export_Configuration.ini"
NOW.... Who wants to show me how to modify this to set the layout viewports in ACAD from iLogic?
I thnk someone, somewhere, owes me a beer.
ps. Yes I know my programs are janky... But what do you expect from a person that isn't a programmer and has never had one programming class.
Imports Autodesk.AutoCAD.Interop.Common
Imports Autodesk.AutoCAD.Interop
Sub Main()
Dim oApp As Inventor.Application = ThisApplication
Dim CurrentYear As String = DateTime.Now.ToString("yyyy")
Dim TimeStamp As String = DateTime.Now.ToString("yyyyMMddHHmmss")
Dim ProgramName As String: ProgramName = "Doug's ACAD Model Space Exporter, " & CurrentYear
Dim i As Integer
If DrawingValidator(i) = 7 Then 'Returns 6 for yes, 7 for no
Exit Sub
End If
If MessageBox.Show("This may take a few minutes," & vbNewLine & vbNewLine & "While processing, DO NOT USE YOUR COMPUTER" & vbNewLine & " 1. Do not use your mouse" & vbNewLine & " 2. Do not use your keyboard" & vbNewLine & " 3. Do not use any input devices" & vbNewLine & vbNewLine & "Would you like to continue?", ProgramName,MessageBoxButtons.YesNo,MessageBoxIcon.Question) = 7 Then
Exit Sub
End If
Dim oDocument As Document: oDocument = ThisApplication.ActiveDocument 'a reference to the active document (the document to be exported), it will crash if you try to use a drawing document, keep it simple.
Dim oDrawDoc As DrawingDocument: oDrawDoc = oApp.ActiveDocument 'access to the Inventor, Active drawing document
Dim FullFileName As String: FullFileName = oDrawDoc.FullFileName 'a string of the Inventor, Active drawing document full path, file name, and extension
temp = Right$(FullFileName, Len(FullFileName) - InStrRev(FullFileName, "\")) 'Remove the path from the Full FileName
FileNameWithoutExtension = Left$(temp, InStrRev(temp, ".") - 1) 'Remove the extension from the Full FileName after it has had the Path removed
Dim MyDocumentsPath As String: MyDocumentsPath = CreateObject("WScript.Shell").specialfolders("mydocuments") 'Get access to the Docments/MyDocuments folder in Windows
Dim InventorFilesFolder As String: InventorFilesFolder = MyDocumentsPath & "\Inventor" 'Create a string for the path of the Inventor folder located in Docments/MyDocuments
Dim ACADBackupFolder As String: ACADBackupFolder = MyDocumentsPath & "\" & "Inventor" & "\" & FileNameWithoutExtension 'Create a string for the path of the Inventor folder located in the folder of the file name
Dim fso As Object : fso = CreateObject("Scripting.FileSystemObject") 'Gain access to a windows function to verify or create a folder
If Not fso.FolderExists(InventorFilesFolder) Then 'Check for MyDocuments/Inventor Folder
fso.CreateFolder (InventorFilesFolder) 'Create MyDocuments/Inventor Folder
End If
If Not fso.FolderExists(ACADBackupFolder) Then 'Check for MyDocuments/Inventor/FileName Folder
fso.CreateFolder (ACADBackupFolder) 'Create MyDocuments/Inventor Folder/FileName
End If
Dim oSheets As Sheets: oSheets = oDrawDoc.Sheets 'Access all of the Inventor Drawing Sheets
Dim oSheet As Sheet 'a variable to iterate through all of Inventor Drawing Sheets
Dim oBorderName As String: oBorderName = oSheets.Item(1).Border.Name 'Get access to the Sheet border Name
Dim oSheetHeight As Integer 'Sheet height in inches, changes per sheet
Dim oSheetWidth As Integer 'Sheet width in inches, changes per sheet
Dim trans As Transaction = ThisApplication.TransactionManager.StartTransaction(oDrawDoc, ProgramName & CurrentYear) 'Undo in one transaction in case something goes wrong
Dim DWGAddIn As TranslatorAddIn: DWGAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC2-122E-11D5-8E91-0010B541CD80}") 'Get access to Inventor DWG Exporter
Dim oContext As TranslationContext: oContext = ThisApplication.TransientObjects.CreateTranslationContext 'Used in the export
oContext.Type = kFileBrowseIOMechanism 'Used in the export
Dim oOptions As NameValueMap: oOptions = ThisApplication.TransientObjects.CreateNameValueMap 'Used in the export
Dim oDataMedium As DataMedium: oDataMedium = ThisApplication.TransientObjects.CreateDataMedium 'Create a DataMedium object, used in the export
Dim FirstSheetName As String: FirstSheetName = Left(oSheets.Item(1).Name, (InStr(oSheets.Item(1).Name, ":") - 1)) 'Sheet Name without : or number
oDataMedium.FileName = ACADBackupFolder & "\" & FileNameWithoutExtension & TimeStamp & ".dwg" 'Get name of file without the extension and add timestamp to it.
If DWGAddIn.HasSaveCopyAsOptions(oDrawDoc, oContext, oOptions) Then 'Check whether the translator has 'SaveCopyAs' options
Dim strIniFile As String
'-----------------------------------------------------------------------------
'Change the following path to wherever you stored your ACAD Export Option File
strIniFile = "C:\TheFolderPathThatContainsThisFile\ACAD_Drawing_Export_Configuration.ini" 'DWG export configuration full path and file name
'-----------------------------------------------------------------------------
oOptions.Value("Export_Acad_IniFile") = strIniFile 'Create the name-value that specifies the ini file to use.
End If
Dim ACADSheet1FileName As String: ACADSheet1FileName = FileNameWithoutExtension & TimeStamp & "_" & FirstSheetName & "_" & "1" 'ACAD exported file name Without Extension
Call DWGAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium) 'Publish document.
Dim ACADCopyFileName As String: ACADCopyFileName = ACADBackupFolder & "\" & FileNameWithoutExtension & "_Sheet_1Thru" & oSheets.Count & "_" & TimeStamp & ".dwg" 'Create a string for a full path, file name, and extension to create a copy of the first document
FileCopy(ACADBackupFolder & "\" & ACADSheet1FileName & ".dwg", ACADCopyFileName) 'Create a copy of the first sheet, This is the full path, full file name, with extension
'FINALLY!
'*********Run Cleanup ACAD procedure***********
Dim ACADDocXScale, ACADDocYScale, ACADDocXPastePoint, ACADDocYPastePoint As Double
Call SheetSizeQuery(oSheets.Item(1).Size, oSheetHeight, oSheetWidth) 'Start with Inventor sheet one size, get the sheet size for sheet 1
Dim ACADapp As Object: ACADapp = CreateObject("AutoCAD.Application") 'Create a new AutoCAD application instance
Dim ACADDoc As Object: ACADDoc = ACADapp.Documents.Open(ACADCopyFileName) 'Open the copy of Sheet 1 in AutoCAD
Dim ACADConsolidatedDoc As Object: ACADConsolidatedDoc = ACADDoc 'up access to the copied drawing
Call ACADConsolidatedDoc.layouts.Add("Sheet" & 1) 'add a new layout tab
Call ACADDocBorderScale(ACADConsolidatedDoc, oBorderName, ACADDocXScale, ACADDocYScale) 'Get the scale of the first sheet to work with
ACADDocXPastePoint = ACADDocXScale * oSheetWidth 'The initial paste point for the first sheet we will copy everything into
ACADDocYPastePoint = ACADDocYScale * 1 'Currently Y is not changing so we will leave it at 1
If oSheets.Count > 1 Then 'Process multiple sheets if there is more than one
For i = 2 To oSheets.Count
Call ACADConsolidatedDoc.layouts.Add("Sheet" & i) 'add a new layout tab
oSheet = oSheets.Item(i) 'Access to the Inventor Sheet
oSheetShortName = Left(oSheet.Name, (InStr(oSheet.Name, ":") - 1)) 'a string of the next exported ACAD sheet to copy
ACADDoc = ACADapp.Documents.Open(ACADBackupFolder & "\" & FileNameWithoutExtension & TimeStamp & "_" & oSheetShortName & "_" & i & ".dwg") 'False means invisible, but ACAD wont stay invisible if you are sending commands to a document
Call ACADDocBorderScale(ACADDoc, oBorderName, ACADDocXScale, ACADDocYScale)
Dim StrPastePoint As String: StrPastePoint = ACADDocXPastePoint & "," & "0" 'ACAD paste point is as a string like, "X,Y", example: "100,0" - - To shift linear, only change one dimension (keep y at 0 to move right, keep x at 0 to move up), it's a string because it will be pasted into the command line as is
Call ACADDoc.sendcommand("_ai_selall" & vbCrLf & "_copybase" & vbCr & "0,0" & vbCr) 'ACAD Sheet Document - Select all in model space and copy
Call Delay(1, "ACAD Copy") 'seconds 'let ACAD finish Copying, you may have to extend this
Call ACADConsolidatedDoc.sendcommand("_pasteclip" & vbCrLf & StrPastePoint & vbCrLf) 'Paste the cocpied info into the Consolidated ACAD file
Call Delay(1, "ACAD processing") 'Give ACAD a second to paste
Call ACADDoc.Close 'ACAD Sheet Document - Close
If i < oSheets.Count Then 'If there are still more sheets to process
Call SheetSizeQuery(oSheet.Size, oSheetHeight, oSheetWidth) 'Get inventor drawing dimensions
ACADDocXPastePoint = ACADDocXPastePoint + (ACADDocXScale * oSheetWidth) 'Cumulative distance, add up the next paste point
ACADDocYPastePoint = 0 'Currently Y is not used so we will leave it at 0
End If
Next
End If
Call ACADapp.ZoomExtents 'all files should be closed except the consolidated, Zoom to everthing in the consolidated file
Call Delay(5, "Zoom Extents") 'Give ACAD a moment to breathe
ACADConsolidatedDoc.layouts("Layout1").Delete
ACADConsolidatedDoc.layouts("Layout2").Delete
Call ACADConsolidatedDoc.sendcommand("snap" & vbCr & "off" & vbCr) 'Turn off ACAD's Document Snap To Grid mode
Call ACADConsolidatedDoc.Save 'Save the master file
Call Delay(5, "Saving New Drawing") 'Give ACAD a moment to breathe
ACADapp.WindowState = 2 '3 = max, 2 = min, 1 = restore
oApp.WindowState = kMaximize '32514 Maximize Inventor '32515'Minimize Inventor
MessageBox.Show("Process complete.", ProgramName, MessageBoxButtons.OK, MessageBoxIcon.Information)
ACADapp.WindowState = 3 '3 = max, 2 = min, 1 = restore
End Sub
Public Function DrawingValidator(FileValueReturn As Integer) 'Returns 7 for NO
Dim CurrentYear As String = Now.Date.ToString("yyyy")
Dim ProgramName As String: ProgramName = "Doug's Drawing Validator " & CurrentYear
Dim oApp As Inventor.Application = ThisApplication
Dim Ret_type As Integer
oRetry:
If ThisApplication.ActiveDocumentType <> kDrawingDocumentObject Then
Ret_type = MessageBox.Show("Drawing Not Found." & vbNewLine & vbNewLine & "Please Verify:" & vbNewLine _
& " 1. Inventor is open and as the active program." & vbNewLine & " 2. The active document is a drawing." _
& vbNewLine & " 2. The drawing has been saved." & vbNewLine & vbNewLine & "Retry?", _
"Drawing not found. - " & ProgramName, _
MessageBoxButtons.YesNo, MessageBoxIcon.Question)
Select Case Ret_type
Case 6 'Yes
FileValueReturn = 6
GoTo oRetry
Case 7 'No
FileValueReturn = 7
End Select
End If
Return FileValueReturn
End Function
Public Function SheetSizeQuery(ByVal shtSize As Inventor.DrawingSheetSizeEnum, ByRef oSheetHeight As Integer, ByRef oSheetWidth As Integer)
Select Case shtSize
Case Is = k12x18InDrawingSheetSize
oSheetHeight = 12
oSheetWidth = 18
Case Is = k18x24InDrawingSheetSize
oSheetHeight = 18
oSheetWidth = 24
Case Is = k24x36InDrawingSheetSize
oSheetHeight = 24
oSheetWidth = 36
Case Is = k30x42InDrawingSheetSize
oSheetHeight = 30
oSheetWidth = 42
Case Is = k36x48InDrawingSheetSize
oSheetHeight = 36
oSheetWidth = 48
Case Is = k9x12InDrawingSheetSize
oSheetHeight = 9
oSheetWidth = 12
Case Is = kA0DrawingSheetSize
oSheetHeight = 33.1
oSheetWidth = 46.8
Case Is = kA1DrawingSheetSize
oSheetHeight = 23.4
oSheetWidth = 33.1
Case Is = kA2DrawingSheetSize
oSheetHeight = 16.5
oSheetWidth = 23.4
Case Is = kA3DrawingSheetSize
oSheetHeight = 11.7
oSheetWidth = 16.5
Case Is = kA4DrawingSheetSize
oSheetHeight = 8.3
oSheetWidth = 11.7
Case Is = kADrawingSheetSize
oSheetHeight = 8.5
oSheetWidth = 11
Case Is = kBDrawingSheetSize
oSheetHeight = 11
oSheetWidth = 17
Case Is = kCDrawingSheetSize
oSheetHeight = 17
oSheetWidth = 22
Case Is = kCustomDrawingSheetSize
oSheetHeight = 34
oSheetWidth = 44
Case Is = kDDrawingSheetSize
oSheetHeight = 22
oSheetWidth = 34
Case Is = kEDrawingSheetSize
oSheetHeight = 34
oSheetWidth = 44
Case Is = kFDrawingSheetSize
oSheetHeight = 28
oSheetWidth = 40
Case Else
DrawingSheetSize = "UNKNOWN"
End Select
End Function
'You need to know the scale factor *FacePalm*
Public Function ACADDocBorderScale(ByVal ACADDoc As Object, ByVal oBorderName As String, ByRef ACADDocXScale As Double, ByRef ACADDocYScale As Double) 'Find the scale of the ACAD block with the border name in it
Dim BorderFound As Boolean: BorderFound = False
Dim ACADDocObj
For Each ACADDocObj In ACADDoc.ModelSpace
If BorderFound = False Then
If InStr(1, ACADDocObj.Name, oBorderName) <> 0 Then
BorderFound = True
ACADDocXScale = ACADDocObj.XScaleFactor
ACADDocYScale = ACADDocObj.YScaleFactor
ACADDocZScale = ACADDocObj.ZScaleFactor
GoTo ScaleFound
End If
End If
Next
ScaleFound :
Return ACADDocXScale
Return ACADDocYScale
End Function
Public Function Delay(PauseTime As Integer, ProcessName As String) 'Function to call a delay when needed
Dim milis As Integer = PauseTime*1000 'Convert seconds to miliseconds
Threading.Thread.Sleep(milis) 'in ms
End Function
