@Ralf_Krieg Here is my code. I am doing this in a part, not an assembly. About two thirds into my program is where I'm trying to create my coordinate system
Sub ExportWorkPointsV2()
'How to use: create your axes in this order: 1st sraight section, 1st bend, 2nd straight, 2nd bend... until final straight section.
'Create a workpoint for the start point and end point. Select all axes and the 2 points, run the macro. Macro will create points at
'each intersection of axis, place them in order, create a UCS using points 1-3, offset the points by the UCS, measure the distance
'of the bend axis to a straight axis, save that as a radius, export the XYZ and R of each point to an excel sheet.
Dim ready As Long
ready = 1
If ready = 0 Then
MsgBox "This macro is not ready yet"
Exit Sub
End If
Dim partDoc As PartDocument
Dim partCompDef As PartComponentDefinition
If ThisApplication.ActiveDocumentType = kPartDocumentObject Then
Set partDoc = ThisApplication.ActiveDocument
Dim partDef As PartComponentDefinition
Set partDef = partDoc.ComponentDefinition
Else
MsgBox "A part must be active"
Exit Sub
End If
Dim points() As WorkPoint
Dim inputPoints() As WorkPoint
Dim axes() As WorkAxis
Dim axisCount As Long
axisCount = 0
Dim inputPointCount As Long
inputPointCount = 0
'verifying the user selected points before beginning
If partDoc.SelectSet.Count > 0 Then
ReDim axes(partDoc.SelectSet.Count - 1)
ReDim inputPoints(partDoc.SelectSet.Count - 1)
Dim selectedObj As Object
'we are searching through each of the selected objects to look for work axes and work points and storingthem in arrays
For Each selectedObj In partDoc.SelectSet
'MsgBox "Type of object is: " & TypeName(selectedObj)
If TypeOf selectedObj Is WorkAxis Then
Set axes(axisCount) = selectedObj
axisCount = axisCount + 1
'MsgBox "Axis found, axisCount = " & Format(axisCount, "0")
End If
If TypeOf selectedObj Is WorkPoint Then
'MsgBox "Type of object is: " & TypeName(selectedObj)
Set inputPoints(inputPointCount) = selectedObj
inputPointCount = inputPointCount + 1
'MsgBox "Input point found, inputPointCount = " & Format(inputPointCount, "0")
End If
Next
ReDim Preserve axes(axisCount)
ReDim Preserve inputPoints(inputPointCount)
'MsgBox "Axis count is "
' ReDim Preserve axes(axisCount - 1)
Else
MsgBox "Nothing selected. Please select all of your bend and straight axes, your start point, and your end point, then try again"
Exit Sub
End If
'verifying that the user only input 2 points, will exit the macro if they did more
If UBound(inputPoints) <> 2 Then
If UBound(inputPoints) > 2 Then
MsgBox "More than 2 points selected. Are you sure you only preselected your start and end points?"
Exit Sub
Else
MsgBox "Not enough points selected. Make sure you preselect your start and end points"
Exit Sub
End If
End If
'making sure the user preselects axes too
If UBound(axes) < 3 Then
MsgBox "You need to select at least 3 axes"
Exit Sub
End If
MsgBox "Number of selected objects: " & Format(partDoc.SelectSet.Count, "0") & vbCrLf & "Number of axes: " & Format(UBound(axes), "0") & vbCrLf & "Number of points: " & Format(UBound(inputPoints), "0") & vbCrLf & "Number of unrecognized geometry selected: " & Format(partDoc.SelectSet.Count - UBound(axes) - UBound(inputPoints), "0")
' MsgBox "Number of axes: " & Format(UBound(axes), "0") & " number of points: " & Format(UBound(inputPoints), "0")
'establishing an array to store radii values
Dim radCount As Integer
radCount = UBound(axes) - 1
radCount = radCount / 2
Dim rad() As Double
ReDim Preserve rad(radCount)
' rad(0) = ThisApplication.MeasureTools.GetMinimumDistance(axes(0), axes(1)) / 2.54
' MsgBox "Radius of 1st bend is: " & Format(rad(0), "0.000") & " in and number of radii is: " & Format(UBound(rad), "0")
'looping to find the radii values, and create points at axis intersections, then storing the data to their respective arrays
ReDim Preserve points(partDoc.SelectSet.Count)
Set points(0) = inputPoints(0)
rad(0) = 0
Dim j As Integer
j = 0
For i = 0 To radCount - 1
'we do not need to add an i = i + 1 in order to iterate during a For Next loop
'we do need to iterate j by 2 to iterate through the axes
rad(i + 1) = ThisApplication.MeasureTools.GetMinimumDistance(axes(j), axes(j + 1))
rad(i + 1) = rad(i + 1) / 2.54
Set points(i + 1) = partDef.WorkPoints.AddByTwoLines(axes(j), axes(j + 2))
'i = i + 1
j = j + 2
Next
Set points(i) = inputPoints(1)
ReDim Preserve points(UBound(points))
rad(i) = 0
For k = 0 To radCount - 1
Dim newPoint As Point
Set newPoint = points(k).Point
'format(newpoint.X,"0.000")
MsgBox "Point " & k + 1 & ": " & Format(newPoint.X, "0.000") & ", " & Format(newPoint.Y, "0.000") & ", " & Format(newPoint.Z, "0.000")
Next
'using points 1, 2 , 3 to create UCS
Dim oTg As TransientGeometry
Set oTg = ThisApplication.TransientGeometry
Dim p1 As Point
Set p1 = partDoc.ComponentDefinition.WorkPoints.AddFixed(oTg.CreatePoint(points(0).Point.X, points(0).Point.Y, points(0).Point.Z))
Dim p2 As Point
Set p2 = partDoc.ComponentDefinition.WorkPoints.AddFixed(oTg.CreatePoint(points(1).Point.X, points(1).Point.Y, points(1).Point.Z))
Dim p3 As Point
Set p3 = partDoc.ComponentDefinition.WorkPoints.AddFixed(oTg.CreatePoint(points(2).Point.X, points(2).Point.Y, points(2).Point.Z))
Dim ucsDef As UserCoordinateSystemDefinition
Set ucsDef = partDoc.ComponentDefinition.UserCoordinateSystems.CreateDefinition.SetByThreePoints(p1, p2, p3)
partDoc.ComponentDefinition.UserCoordinateSystems.Add (ucsDef)
'creating a matrix to offset the workpoints
Dim ucsMat As Matrix
Set ucsMat = ucsDef.Transformation
Call ucsMat.Invert
'Dim newUCS As UserCoordinateSystem
'Set newUCS = partDef.UserCoordinateSystems.Add.CreateDefinition.SetByThreePoints(points(0), points(1), points(2))
'Dim newUCSmat As Matrix
'Set yourUCSmat = newUCS.Transformation
'Call newUCSmat.Invert
'printing the values to a csv excel sheet
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
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
Dim uom As UnitsOfMeasure
Set uom = partDoc.UnitsOfMeasure
Print #1, "Point" & "," & _
"X:" & "," & _
"Y:" & "," & _
"Z:" & "," & _
"Radius:" & "," & _
"Work point name:"
'"Item: " & "," & _ partDoc.DisplayName
For i = 0 To UBound(points)
Dim newPoint As Point
Set newPoint = points(i).Point
Call newPoint.TransformBy(newUCSmat)
Dim xCoord As Double
xCoord = uom.ConvertUnits(newPoint.X, _
kCentimeterLengthUnits, kInchLengthUnits)
Dim yCoord As Double
yCoord = uom.ConvertUnits(newPoint.Y, _
kCentimeterLengthUnits, kInchLengthUnits)
Dim zCoord As Double
zCoord = uom.ConvertUnits(newPoint.Z, _
kCentimeterLengthUnits, kInchLengthUnits)
Print #1, i + 1 & "," & _
Format(xCoord, "0.000") & "," & _
Format(yCoord, "0.000") & "," & _
Format(zCoord, "0.000") & "," & _
Format(rad(i), "0.000") & "," & _
points(i).Name
Next
Close #1
MsgBox "Finished writing data to """ & filename & """"
End If
End Sub
