Hello
First, I've noticed that multivalue parameters are always alphabetical sorted. That may be no problem with single workpoints. But for the pattern is the correct order of the patterns is necessary. You could always rename the patterns to "reorder" them, but I would prefer to create fx parameters for each pattern. For each pattern a pair of paramters. In the text parameter "PatternNameX" (where X is the order number) is the value the name of the pattern. In the numeric, unitless parameter "PatternFields" is the value the maximum number of pattern elements. This way, you can add more patterns and remove patterns and change the maximum field numbers. The picture shows the parameters for a scenario with workpoints 4 pattern features.
Hope all is as expected.
Option Explicit on
Class ThisRule
Private Structure UWorkPoint
Dim Name As String
Dim Parent As String
Dim X As String
Dim Y As String
Dim Z As String
End Structure
Private uWP As UWorkPoint
Private uWorkPointList As List(Of UWorkPoint)
Private uPatternList As List(Of UWorkPoint)
Private sCaption As String
Public Sub Main()
Dim oDoc As PartDocument = ThisDoc.Document
Dim fxNumber As String = String.Empty
Dim fxCustomer As String = String.Empty
Dim fxType As String = String.Empty
Dim oWPs As New List(Of String)
Dim iWPCount As Integer
Dim oUserParam As UserParameter
Dim iMaxCount As Integer = oDoc.ComponentDefinition.Parameters.UserParameters.Count
Dim i As Integer
Dim oPatternNames As New List(Of String)
Dim oPatternNumbers As New List(Of String)
uWorkPointList = New List(Of UWorkPoint)
uPatternList = New List(Of UWorkPoint)
sCaption = "iLogic Export Workpoints 2 CSV"
For i = 1 To iMaxCount
For Each oUserParam In oDoc.ComponentDefinition.Parameters.UserParameters
Select Case oUserParam.Name.ToUpper
Case "PATTERNNAME" & i : oPatternNames.Add(oUserParam.Value)
Case "PATTERNFIELDS" & i : oPatternNumbers.Add(oUserParam.Value)
Case "WP_FIELDS" : iWPCount = oUserParam.Value
Case "WP_EXPORT"
oWPs = SortList(MultiValue.List("WP_Export").Cast(Of String)().ToList())
If oWPs.Count = 0 Then
oWPs = New List(Of String)
oWPs.Add(oUserParam.Value.ToString)
End If
Case "NUMBER" : fxNumber = oUserParam.Value
Case "CUSTOMER" : fxCustomer = oUserParam.Value
Case "TYPE" : fxType = oUserParam.Value
End Select
Next
Next
For Each item As String In oWPs
IsWorkpoint(item, oDoc)
Next
Do While uWorkPointList.Count < iWPCount
uWP = CreateuWP("SINGLE_Work Point")
uWorkPointList.Add(uWP)
Loop
'search all patterns for the names in pattern list
For i = 0 To oPatternNames.Count - 1
IsRectPattern(oPatternNames.Item(i), oPatternNumbers.Item(i), oDoc)
IsCircPattern(oPatternNames.Item(i), oPatternNumbers.Item(i), oDoc)
Next
ExportWorkpoints(uWorkPointList, fxNumber, fxCustomer, fxType)
End Sub
Private Sub IsWorkpoint(ByVal item As String, ByVal oDoc As PartDocument)
Dim oWP As WorkPoint
For Each oWP In oDoc.ComponentDefinition.WorkPoints
If (item.ToUpper = oWP.Name.ToUpper) And (oWP.Visible = True) Then
If oWP.IsCoordinateSystemElement = False Then
uWP = CreateuWP("Single", oWP)
uWorkPointList.Add(uWP)
End If
End If
Next
End Sub
Private Sub IsRectPattern(ByVal item As String, ByVal iColCount As Integer, ByVal oDoc As PartDocument)
Try
Dim oRPF As RectangularPatternFeature
For Each oRPF In oDoc.ComponentDefinition.Features.RectangularPatternFeatures
If item.ToUpper = oRPF.Name.ToUpper Then
If oRPF.Suppressed = True Then
MsgBox("Rectangular Pattern " & oRPF.Name & " is suppressed. Skipping and continue next", MsgBoxStyle.Information, sCaption)
Else
uPatternList.Clear()
GetPointsRect(oRPF, oRPF.Name, iColCount)
Do While uPatternList.Count < iColCount
uWP = CreateuWP(oRPF.Name)
uPatternList.Add(uWP)
Loop
uWorkPointList.AddRange(uPatternList)
End If
End If
Next
Catch ex As Exception
Logger.Debug(ex.Message)
End Try
End Sub
Private Sub IsCircPattern(ByVal item As String, ByVal iColCount As Integer, ByVal oDoc As PartDocument)
Try
Dim oCPF As CircularPatternFeature
For Each oCPF In oDoc.ComponentDefinition.Features.CircularPatternFeatures
If item.ToUpper = oCPF.Name.ToUpper Then
If oCPF.Suppressed = True Then
MsgBox("Circular Pattern " & oCPF.Name & " is suppressed. Skipping and continue next", MsgBoxStyle.Information, sCaption)
Else
uPatternList.Clear()
GetPointsCirc(oCPF, oCPF.Name, iColCount)
Do While uPatternList.Count < iColCount
uWP = CreateuWP(oCPF.Name)
uPatternList.Add(uWP)
Loop
uWorkPointList.AddRange(uPatternList)
End If
End If
Next
Catch ex As Exception
Logger.Debug(ex.Message)
End Try
End Sub
Private Sub GetPointsRect(ByVal oPatternFeature As RectangularPatternFeature, ByVal sPatternFeature As String, ByVal iColCount As Integer)
Try
Dim i As Integer
Dim j As Integer
Dim oParentFeatures As ObjectCollection = oPatternFeature.ParentFeatures
For i = 1 To oParentFeatures.Count
If TypeOf oParentFeatures(i) Is WorkPoint Then
If oParentFeatures(i).Visible = True Then
If oParentFeatures(i).IsCoordinateSystemElement = False Then
uWP = CreateuWP(sPatternFeature, oParentFeatures(i))
If Not uWP.Name Is Nothing Then uPatternList.Add(uWP)
End If
Else
uWP = CreateuWP(sPatternFeature)
uPatternList.Add(uWP)
End If
ElseIf TypeOf oParentFeatures(i) Is RectangularPatternFeature Then
If oParentFeatures(i).Suppressed = False Then
GetPointsRect(oParentFeatures(i), sPatternFeature, iColCount)
End If
ElseIf TypeOf oParentFeatures(i) Is CircularPatternFeature Then
If oParentFeatures(i).Suppressed = False Then
GetPointsCirc(oParentFeatures(i), sPatternFeature, iColCount)
End If
End If
Next
Dim oPatternElements As FeaturePatternElements = oPatternFeature.PatternElements
For i = 1 To oPatternElements.Count
If oPatternElements(i).Suppressed = False Then
Dim oResultFeatures As ObjectCollection = oPatternElements(i).ResultFeatures
If Not oResultFeatures Is Nothing Then
For j = 1 To oResultFeatures.Count
If TypeOf oResultFeatures(j) Is WorkPoint Then
If oResultFeatures(j).Visible = True Then
If oResultFeatures(j).IsCoordinateSystemElement = False Then
uWP = CreateuWP(sPatternFeature, oResultFeatures(j))
If Not uWP.Name Is Nothing Then uPatternList.Add(uWP)
End If
End If
Else
uWP = CreateuWP(sPatternFeature)
uPatternList.Add(uWP)
End If
Next
End If
End If
Next
Catch ex As Exception
Logger.Debug(ex.Message)
End Try
End Sub
Private Sub GetPointsCirc(ByVal oPatternFeature As CircularPatternFeature, ByVal sPatternFeature As String, ByVal icolCount As Integer)
Dim i As Integer
Dim j As Integer
Dim oParentFeatures As ObjectCollection = oPatternFeature.ParentFeatures
For i = 1 To oParentFeatures.Count
If TypeOf oParentFeatures(i) Is WorkPoint Then
If oParentFeatures(i).Visible = True Then
If oParentFeatures(i).IsCoordinateSystemElement = False Then
uWP = CreateuWP(sPatternFeature, oParentFeatures(i))
If Not uWP.Name Is Nothing Then uPatternList.Add(uWP)
End If
Else
uWP = CreateuWP(sPatternFeature)
uPatternList.Add(uWP)
End If
ElseIf TypeOf oParentFeatures(i) Is RectangularPatternFeature Then
If oParentFeatures(i).Suppressed = False Then
GetPointsRect(oParentFeatures(i), sPatternFeature, icolCount)
End If
ElseIf TypeOf oParentFeatures(i) Is CircularPatternFeature Then
If oParentFeatures(i).Suppressed = False Then
GetPointsCirc(oParentFeatures(i), sPatternFeature, icolCount)
End If
End If
Next
Dim oPatternElements As FeaturePatternElements = oPatternFeature.PatternElements
For i = 1 To oPatternElements.Count
If oPatternElements(i).Suppressed = False Then
Dim oResultFeatures As ObjectCollection = oPatternElements(i).ResultFeatures
If Not oResultFeatures Is Nothing Then
For j = 1 To oResultFeatures.Count
If TypeOf oResultFeatures(j) Is WorkPoint Then
If oResultFeatures(j).Visible = True Then
If oResultFeatures(j).IsCoordinateSystemElement = False Then
uWP = CreateuWP(sPatternFeature, oResultFeatures(j))
If Not uWP.Name Is Nothing Then uPatternList.Add(uWP)
End If
Else
uWP = CreateuWP(sPatternFeature)
uPatternList.Add(uWP)
End If
End If
Next
End If
End If
Next
End Sub
Private Sub ExportWorkpoints(ByVal uWorkPointList As List(Of UWorkPoint), ByVal fxNumber As String, ByVal fxCustomer As String, ByVal fxType As String)
Dim partDoc = ThisApplication.ActiveDocument
Dim partDef = partDoc.ComponentDefinition
Dim dlmtr As String = ";"
Dim filePath As String
Dim fileName As String
Dim i As Integer
Dim j As Integer
filePath = ThisDoc.Path & "\"
fileName = "CSV Name" & fxNumber & ".csv"
Dim expfile As System.IO.StreamWriter = System.IO.File.CreateText(filePath + fileName)
Dim aFileData(3, uWorkPointList.Count + 3) As String
aFileData(0, 0) = "Number"
aFileData(1, 0) = fxNumber
aFileData(0, 1) = "Customer"
aFileData(1, 1) = fxCustomer
aFileData(0, 2) = "Type"
aFileData(1, 2) = fxType
aFileData(0, 3) = "Name"
aFileData(1, 3) = "X"
aFileData(2, 3) = "Y"
aFileData(3, 3) = "Z"
For i = 4 To uWorkPointList.Count + 3
Try
aFileData(0, i) = uWorkPointList.Item(i - 4).Name
aFileData(1, i) = uWorkPointList.Item(i - 4).X
aFileData(2, i) = uWorkPointList.Item(i - 4).Y
aFileData(3, i) = uWorkPointList.Item(i - 4).Z
Catch
aFileData(0, i) = "f"
aFileData(1, i) = "f"
aFileData(2, i) = "f"
aFileData(3, i) = "f"
End Try
Next
For i = 0 To 3
For j = 0 To uWorkPointList.Count + 3
expfile.Write(aFileData(i, j) & dlmtr)
Next
expfile.Write(vbCrLf)
Next
expfile.Close()
ThisDoc.Launch(filePath + fileName)
End Sub
Private Function CreateuWP(ByVal sPrefix As String, Optional ByVal oWP As WorkPoint = Nothing) As UWorkPoint
If oWP Is Nothing Then
'create Dummy entry
uWP.Name = sPrefix & "_f"
uWP.X = "f"
uWP.Y = "f"
uWP.Z = "f"
Else
' Check for duplicate in uworkpointlist
If uWorkPointList.Exists(Function(x) x.Name = "Single_" & oWP.Name) = True Then
Logger.Debug("Skipped duplicate workpoint " & oWP.Name)
Return Nothing
Else
uWP = New UWorkPoint
uWP.Name = sPrefix & "_" & oWP.Name
uWP.X = Round(oWP.Point.X * 10, 2).ToString
uWP.Y = Round(oWP.Point.Y * 10, 2).ToString
uWP.Z = Round(oWP.Point.Z * 10, 2).ToString
End If
End If
Return uWP
End Function
Private Function SortList(ByVal oSourceList As List(Of String)) As List(Of String)
Dim listOfLines As New Dictionary(Of Integer, String)
For Each line As String In oSourceList
Dim part() As String = Line.Split(New Char() {"t"}, StringSplitOptions.RemoveEmptyEntries)
listOfLines.Add(Integer.Parse(part(part.Length - 1)), Line)
Next
Dim listOfKeys As List(Of Integer) = listOfLines.Keys.ToList
listOfKeys.Sort()
Dim oSortedList As New List(Of String)
For Each key As String In listOfKeys
oSortedList.Add(listOfLines(key))
Next
Return oSortedList
End Function
End Class
R. Krieg
RKW Solutions
www.rkw-solutions.com
