Message 1 of 15
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello everybody,
I would like your help with an excel file containing the exact names and paths of the drawings. What I would like to do is to open the specified drawings one by one from Inventor and save the drawings in pdf and dxf format to the location from where the excel file is opened.
Attached I attach the excel vba macro I have written so far and the image that excel will pull in and examine to see
where the drawings are located.
I would appreciate your help, this task takes a lot of time and effort in my work and I am trying to shorten the time invested.
Thank you and have a nice day everyone!
Code here:
' QuickSort function that arranges parts in alphabetical order
' Whether .IPT or .IAM file
Private Sub QuickSort(ByRef arr() As String, ByVal low As Long, ByVal high As Long)
Dim pivot As Variant
Dim i As Long, j As Long
pivot = arr((low + high) \ 2)
i = low
j = high
Do
Do While arr(i) < pivot
i = i + 1
Loop
Do While arr(j) > pivot
j = j - 1
Loop
If i <= j Then
Dim temp As String
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
i = i + 1
j = j - 1
End If
Loop Until i > j
If low < j Then QuickSort arr, low, j
If i < high Then QuickSort arr, i, high
End Sub
Private Sub GetPartPaths(filePath As String)
' Create an array of access routes
Dim pathArray() As String
Dim fso As New FileSystemObject
ReDim pathArray(0)
Dim totalPaths As Integer
If (fso.FileExists(filePath)) Then
If (InStr(Join(pathArray), filePath) = 0) Then
ReDim Preserve pathArray(UBound(pathArray) + 1)
pathArray(UBound(pathArray)) = filePath
totalPaths = totalPaths + 1
End If
Else
'Case where the file cannot be found
End If
End Sub
'Call the GetPartPaths function for each part
For Each oDoc In oApp.Documents
If Right(oDoc.FullFileName, 4) = ".ipt" Or Right(oDoc.FullFileName, 4) = ".iam" Then
If oDoc.FullFileName <> currentFile Then
GetPartPaths (oDoc.FullFileName)
iCounter = iCounter + 1
End If
End If
Next oDoc
'Routes stored in an array go back to the original code
For i = 0 To UBound(pathArray)
'pathArray(i) contains the key of the sequence
Next i
Sub CountPart()
Dim oApp As Application
Dim oDoc As Document
Dim iCounter As Integer
Dim currentFile As String
Dim xlApp As Excel.Application
Dim xlWorkbook As Excel.Workbook
Dim xlWorksheet As Excel.WorkSheet
Dim lastRow As Long
Dim pathArray() As String
Dim fso As New FileSystemObject
Dim oCompDef As Inventor.ComponentDefinition
Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition
iCounter = 0
Set oApp = GetObject(, "Inventor.Application")
currentFile = oApp.ActiveDocument.FullFileName
' Create an array to store the part names and paths
Dim parts() As String
' Create an instance of Excel, add a workbook and a worksheet
Set xlApp = New Excel.Application
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Worksheets(1)
xlWorksheet.Name = "Part List"
' Set the column headers
xlWorksheet.Cells(1, 1).Value = "PartName"
xlWorksheet.Cells(1, 2).Value = "PartPath"
xlWorksheet.Cells(1, 3).Value = "Mass (Kg)"
' Iterate through the documents in the Inventor session
For Each oDoc In oApp.Documents
If Right(oDoc.FullFileName, 4) = ".ipt" Or Right(oDoc.FullFileName, 4) = ".iam" Then
If oDoc.FullFileName <> currentFile Then
' Get the part name and path
Dim partName As String
Dim partPath As String
partName = fso.GetFile(oDoc.FullFileName).Name
partPath = fso.GetFile(oDoc.FullFileName).Path
' Append the data to the parts array
On Error Resume Next
ReDim Preserve parts(iCounter)
parts(iCounter) = partName & ";" & partPath
If Err.Number <> 0 Then
' Write the missing file name to a .txt file
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim txtFile As Object
Set txtFile = fs.OpenTextFile("C:\Vault\Designs\missing_files.txt", 8, True)
txtFile.WriteLine (partName & ";" & partPath)
txtFile.Close
' Reset the error handling
On Error GoTo 0
Else
iCounter = iCounter + 1
End If
End If
End If
Next oDoc
' Sort the parts array in ascending alphabetical order
If iCounter = 0 Then
MsgBox "There are no .ipt and .iam files in the Inventor session.", vbOKOnly, "IPT and IAM File Count"
Exit Sub
End If
QuickSort parts, 0, UBound(parts)
' Prompt the user to select the location to save the data, create variable to represent the Inventor.FileDialog
Dim saveDlg As Inventor.FileDialog
'this method sets the value of that variable you just created, without using 'Set' keyword
Call ThisApplication.CreateFileDialog(saveDlg)
saveDlg.DialogTitle = "Select the location to save the data"
saveDlg.Filter = "Excel Files (*.xlsx)|*.xlsx|All files (*.*)|*.*"
saveDlg.FilterIndex = 1
saveDlg.CancelError = True
On Error Resume Next 'pause normal error handling
Call saveDlg.ShowSave 'this is a Sub, so no 'Return' value
If Err <> 0 Then Exit Sub 'if Error when showing dialog, then exit Sub
If saveDlg.fileName = "" Then Exit Sub 'if nothing selected, exit Sub
' Create the text file and write the sorted parts to it
For i = 0 To UBound(parts)
Dim partData() As String
partData = Split(parts(i), ";")
xlWorksheet.Cells(lastRow, 1).Value = partData(0)
xlWorksheet.Cells(lastRow, 2).Value = partData(1)
lastRow = lastRow + 1
Next i
' Save the workbook and close Excel
xlWorkbook.SaveAs saveDlg.fileName, FileFormat:=xlOpenXMLWorkbook
'Close the original Excel document
xlWorkbook.Close
xlApp.Quit
MsgBox "There are " & iCounter & " .ipt and .iam files in the Inventor session." & vbCrLf & "Data has been saved to: " & saveDlg.fileName, vbOKOnly, "IPT and IAM File Count"
End Sub
Sub OpenIDW_v1()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.WorkSheet
Dim idwFile As String
Dim pdfComplete As Boolean
Dim dxfComplete As Boolean
' Prompt user to select Excel file
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False
Dim xlFilename As Variant
xlFilename = xlApp.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "Select Excel File to Open")
If xlFilename = False Then Exit Sub
' Open Excel file and select worksheet
Set xlBook = xlApp.Workbooks.Open(xlFilename)
Set xlSheet = xlBook.Worksheets(1)
' Get number of file paths in column B
Dim lastRow As Long
lastRow = xlSheet.Cells(xlSheet.Rows.Count, 2).End(xlUp).Row
' Loop through rows in Excel worksheet
For i = 1 To lastRow
' Get IDW file path from Excel cell
idwFile = xlSheet.Cells(i, 2).Value
' Open IDW file in Autodesk Inventor
Call ThisApplication.Documents.Open(idwFile)
' Prompt user to confirm PDF and DXF backup is complete
Dim filePath As String
Dim fileName As String
Dim fileNameWithPath As String
filePath = ThisDoc.Path
fileName = ThisDoc.fileName(False) 'without extension
fileNameWithPath = filePath & "\" & fileName
ThisDoc.Document.SaveAs fileNameWithPath & ".dxf", True
ThisDoc.Document.SaveAs fileNameWithPath & ".pdf", True
pdfComplete = MsgBox("Is the PDF backup complete?", vbYesNo) = vbYes
dxfComplete = MsgBox("Is the DXF backup complete?", vbYesNo) = vbYes
' Close IDW file if PDF and DXF backup is complete
If pdfComplete And dxfComplete Then
Call ThisApplication.ActiveDocument.Close(True)
End If
Next i
' Close Excel file
xlBook.Close SaveChanges:=False
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
I would like to receive your comments and advice on how to improve it in code!
Solved! Go to Solution.
