一位顧客在零件中創建了許多工作點，然后客戶需要一個Excel文件，包含這些工作點的坐標。下面的一個VBA宏，將創建一個CSV文件，其中包含了零件中工作點的坐標。如果您在運行宏之前選擇了一部分工作點，那么這個宏將出現一個選項，提示您只會輸出已經選定的工作點或輸出所有的工作點。如果沒有選定的工作點，那么它會導出所有的工作點。
這個宏開始并沒有考慮到單位問題，因為Inventor的默認單位是CM，而不是MM，所以輸出的尺寸是不正確的，下面是更新。
更新：自從我第一次發布這篇文章，我收到了有關宏程序如何使用的文件的當前單位的問題。我已經修改了下面的代碼。在此之前，它是使用內部厘米的長度單位。它現在使用的文件中指定的長度，但它忽略了文件中指定的小數點后數字的數量，總是寫入多達8位小數。
程序如下:
Public Sub ExportWorkPoints()
' Get the active part document.
Dim partDoc As PartDocument
If ThisApplication.ActiveDocumentType = kPartDocumentObject Then
Set partDoc = ThisApplication.ActiveDocument
Else
MsgBox "A part must be active."
Exit Sub
End If
' Check to see if any work points are selected.
Dim points() As WorkPoint
Dim pointCount As Long
pointCount = 0
If partDoc.SelectSet.Count > 0 Then
' Dimension the array so it can contain the full
' list of selected items.
ReDim points(partDoc.SelectSet.Count - 1)
Dim selectedObj As Object
For Each selectedObj In partDoc.SelectSet
If TypeOf selectedObj Is WorkPoint Then
Set points(pointCount) = selectedObj
pointCount = pointCount + 1
End If
Next
ReDim Preserve points(pointCount - 1)
End If
' Ask to see if it should operate on the selected points
' or all points.
Dim getAllPoints As Boolean
getAllPoints = True
If pointCount > 0 Then
Dim result As VbMsgBoxResult
result = MsgBox("Some work points are selected. " & _
"Do you want to export only the " & _
"selected work points? (Answering " & _
"""No"" will export all work points)", _
vbQuestion + vbYesNoCancel)
If result = vbCancel Then
Exit Sub
End If
If result = vbYes Then
getAllPoints = False
End If
Else
If MsgBox("No work points are selected. All work points" & _
" will be exported. Do you want to continue?", _
vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
End If
Dim partDef As PartComponentDefinition
Set partDef = partDoc.ComponentDefinition
If getAllPoints Then
ReDim points(partDef.WorkPoints.Count - 2)
' Get all of the workpoints, skipping the first,
' which is the origin point.
Dim i As Integer
For i = 2 To partDef.WorkPoints.Count
Set points(i - 2) = partDef.WorkPoints.Item(i)
Next
End If
' Get the filename to write to.
Dim dialog As FileDialog
Dim filename As String
Call ThisApplication.CreateFileDialog(dialog)
With dialog
.DialogTitle = "Specify Output .CSV File"
.Filter = "Comma delimited file (*.csv)|*.csv"
.FilterIndex = 0
.OptionsEnabled = False
.MultiSelectEnabled = False
.ShowSave
filename = .filename
End With
If filename <> "" Then
' Write the work point coordinates out to a csv file.
On Error Resume Next
Open filename For Output As #1
If Err.Number <> 0 Then
MsgBox "Unable to open the specified file. " & _
"It may be open by another process."
Exit Sub
End If
' Get a reference to the object to do unit conversions.
Dim uom As UnitsOfMeasure
Set uom = partDoc.UnitsOfMeasure
' Write the points, taking into account the current default
' length units of the document.
For i = 0 To UBound(points)
Dim xCoord As Double
xCoord = uom.ConvertUnits(points(i).Point.X, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
Dim yCoord As String
yCoord = uom.ConvertUnits(points(i).Point.Y, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
Dim zCoord As String
zCoord = uom.ConvertUnits(points(i).Point.Z, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
Print #1, points(i).Name & "," & _
Format(xCoord, "0.00000000") & "," & _
Format(yCoord, "0.00000000") & "," & _
Format(zCoord, "0.00000000")
Next
Close #1
MsgBox "Finished writing data to """ & filename & """"
End If
End Sub