Automation Functions
Array Functions
Array Remove Item
Private Sub ArrayRemoveItem(ItemArray As Variant, ByVal ItemElement As
Long)
Dim lCtr As Long: Dim lTop As Long: Dim lBottom As Long
If Not IsArray(ItemArray) Then
Err.Raise 13, , "Type Mismatch."
Exit Sub
End If
lTop = UBound(ItemArray)
lBottom = LBound(ItemArray)
If ItemElement < lBottom Or ItemElement > lTop Then
Err.Raise 9, , "Subscript out of Range."
Exit Sub
End If
For lCtr = ItemElement To lTop - 1
ItemArray(lCtr) = ItemArray(lCtr + 1)
Next
On Error GoTo ErrorHandler:
ReDim Preserve ItemArray(lBottom To lTop - 1)
Exit Sub
ErrorHandler:
Err.Raise Err.Number, , _
"You must pass a resizable array to this function."
End Sub
Delete HS Objects Array
Sub DeleteHSObjectsArray(InputArray As Variant)
If UBound(InputArray) = 0 Then
Exit Sub
End If
For X = 0 To UBound(InputArray) - 1
MyHSFactory.DeleteObjectForDatum InputArray(X)
Next X
End Sub
Delete Non Surface (From Array)
Sub DeleteNonSurface(InputObj As Variant)
On Error GoTo KBlast
Dim KMeas
Set KMeas = TheSPAWorkbench.GetMeasurable(InputObj)
If KMeas.GeometryName <> CatMeasurableSurface Then
MyHSFactory.DeleteObjectForDatum InputObj
End If
Exit Sub
KBlast:
If MySel.Count <> 0 Then
MySel.Clear
End If
MySel.Add InputObj
MySel.Delete
End Sub
Exists In Array
Function ExistsInArray(CurName As String, NameArray As Variant) As
Boolean
If UBound(NameArray) = 0 Then
ExistsInArray = False
Exit Function
End If
For X = 0 To UBound(NameArray)
If IsEmpty(NameArray(X)) = False Then
If CurName = NameArray(X) Then
ExistsInArray = True
Exit Function
End If
End If
Next X
ExistsInArray = False
End Function
Force Color Array
Sub ForceColorArray(InputArray As Variant, R As Integer, G As Integer,
B As Integer, LineTypeNo As Integer, PointTypeNo As Integer,
ThicknessNo As Integer)
Dim VizProp As VisPropertySet
Set VizProp = MySel.VisProperties
If MySel.Count <> 0 Then
MySel.Clear
End If
For gg = 0 To UBound(InputArray) - 1
MySel.Add InputArray(gg)
Next gg
If R <> 1000 Or G <> 1000 Or B <> 1000 Then
VizProp.SetVisibleColor R, G, B, 1
End If
If LineTypeNo <> 1000 Then
VizProp.SetVisibleLineType LineTypeNo, 1
End If
If PointTypeNo <> 1000 Then
VizProp.SetSymbolType PointTypeNo
End If
If ThicknessNo <> 1000 Then
VizProp.SetVisibleWidth ThicknessNo, 1
End If
MySel.Clear
End Sub
Generate Length Parameters From Dbl Array
Function GenerateLengthParametersFromDblArray(ParmList As Parameters,
DblArr As Variant) As Variant
'Default units are mm.
Dim ParmArr()
ReDim ParmArr(UBound(DblArr))
For X = 0 To UBound(DblArr)
Set ParmArr(X) = ParmList.CreateDimension("STD_Rad" & Format(X,
"00"), "LENGTH", DblArr(X))
Next X
GenerateLengthParametersFromDblArray = ParmArr
End Function
Generate Real Parameters From Dbl Array
Function GenerateRealParametersFromDblArray(ParmList As Parameters,
DblArr As Variant) As Variant
Dim ParmArr()
ReDim ParmArr(UBound(DblArr))
For X = 0 To UBound(DblArr)
Set ParmArr(X) = ParmList.CreateReal("STD_Rad" & Format(X, "00"),
DblArr(X))
Next X
GenerateRealParametersFromDblArray = ParmArr
End Function
Is array empty
Function isarrempty(arrayobj) As Boolean
On Error GoTo failed
num = UBound(arrayobj)
If num < 0 Then
GoTo failed
Else
isarrempty = False
Exit Function
End If
failed:
isarrempty = True
End Function
Load file to array
Sub loadfiletoarray(path, myarray,delimeter)
filename = path
Open filename For Input As 1
ReDim myarray(0)
counter = 0
While Not EOF(1)
lineval = ""
Line Input #1, lineval
lineval = Split(lineval, delimeter)
myarray(UBound(myarray)) = lineval
ReDim Preserve myarray(UBound(myarray) + 1)
counter = counter + 1
Wend
Close #1
End Sub
‘Comments: The text file should contain all elements separated by a delimiter such as a comma
or another type of special character. Every line should be considered an element you want in
the array.
'Example a text file containing only this:
'name,lastname,age,haircolor
'jose,guzman,34,black'
'john,doe,10,brown
'When running the function it will create an array containing 3 arrays each of which will have 4
sub elements.
'array 1 :
'1st element: name
'2nd element: lastname
'3rd element: age
'4th element: haircolor
'array 2 :
'1st element: jose
'2nd element: Guzman
'3rd element: 34
'4th element: black
'array 3 :
'1st element: john
'2nd element: doe
'3rd element: 10
'4th element: brown
Make Array From Excel Column
Function MakeArrayFromExcelColumn(ColumnNo As Integer, TotalRows As
Integer) As Variant
Dim CurArr()
ReDim CurArr(1)
CurArr(0) = ""
For MK = 2 To TotalRows
Dim CurStr As String
CurStr = CStr(CurCells(MK, ColumnNo).Value)
Dim WCounter As Integer
WCounter = 0
While WCounter < UBound(CurArr) And CurStr <> CurArr(WCounter)
WCounter = WCounter + 1
Wend
If WCounter >= UBound(CurArr) Then
CurArr(UBound(CurArr)) = CurStr
ReDim Preserve CurArr(UBound(CurArr) + 1)
End If
Next MK
MakeArrayFromExcelColumn = CurArr
End Function
Make Array From Search
Function MakeArrayFromSearch(SearchStr As String) As Variant
MySel.Search SearchStr
Dim TempArr()
If MySel.Count = 0 Then
ReDim TempArr(0)
MakeArrayFromSearch = TempArr
Exit Function
End If
ReDim TempArr(MySel.Count - 1)
For X = 0 To MySel.Count - 1
Set TempArr(X) = MySel.Item(X + 1).Value
Next X
MakeArrayFromSearch = TempArr
End Function
Make Array Mid Doubles
Function MakeArrayMidDoubles(InputArr As Variant) As Variant
Dim MidArr()
ReDim MidArr(UBound(InputArr) - 1)
For X = 0 To UBound(InputArr) - 1
Dim FVal
FVal = InputArr(X)
Dim SVal
SVal = InputArr(X + 1)
MidArr(X) = (CDbl(FVal) + CDbl(SVal)) / 2
Next X
MakeArrayMidDoubles = MidArr
End Function
Put Contents Of Hybrid Body Into Array
Function PutContentsOfHybridBodyIntoArray(GeomSet As HybridBody) As
Variant
Dim MasterArr()
ReDim MasterArr(GeomSet.HybridShapes.Count - 1)
For X = 1 To GeomSet.HybridShapes.Count
Set MasterArr(X - 1) = GeomSet.HybridShapes.Item(X)
Next X
PutContentsOfHybridBodyIntoArray = MasterArr
End Function
Replace Last Elements In Array
Function ReplaceLastElementsInArray(MainArray As Variant,
SubstituteArray As Variant) As Variant
Dim WC As Integer
WC = UBound(MainArray)
Dim SC As Integer
SC = 0
While WC >= 0 And SC <= UBound(SubstituteArray)
MainArray(WC) = SubstituteArray(SC)
SC = SC + 1
WC = WC - 1
Wend
ReplaceLastElementsInArray = MainArray
End Function
Return Activity Parm From Array
Function ReturnActivityParmFromArray(CurArr As Variant) As Parameter
Dim XO As Integer 'Used to find the Parent of a UDF
XO = 0
While XO < UBound(CurArr)
If TypeName(CurArr(XO)) = "BoolParam" Then
If InStr(CurArr(XO).Name, "\Activity") <> 0 Then
Set ReturnActivityParmFromArray = CurArr(XO)
Exit Function
End If
End If
XO = XO + 1
Wend
set ReturnActivityParmFromArray = Nothing
End Function
Return Axis Sys From Array By Name
Function ReturnAxisSysFromArrayByName(AxisArr As Variant, NameStr As
String) As AxisSystem
For X = 0 To UBound(AxisArr)
If AxisArr(X).Name = NameStr Then
Set ReturnAxisSysFromArrayByName = AxisArr(X)
Exit Function
End If
Next
End Function
Return Closest Element In Array
Function ReturnClosestElementInArray(SampleArr As Variant, TestObj As
Variant) As Variant
Dim WinningDist As Double
WinningDist = 100000023
Dim WinningObj
For X = 0 To UBound(SampleArr)
If IsEmpty(SampleArr(X)) = False Then
Dim CurMeas
Set CurMeas = TheSPAWorkbench.GetMeasurable(SampleArr(X))
Dim CurDist As Double
CurDist = CurMeas.GetMinimumDistance(TestObj)
If CurDist < WinningDist Then
WinningDist = CurDist
Set WinningObj = SampleArr(X)
End If
End If
Next X
Set ReturnClosestElementInArray = WinningObj
End Function
Return Closest Index In Array
Function ReturnClosestIndexInArray(SampleArr As Variant, TestNum As
Variant) As Integer
Dim WinningDist As Double
WinningDist = 100000023
Dim WinningObj
For X = 0 To UBound(SampleArr)
Dim CurNum
CurNum = SampleArr(X)
Dim CurDist As Double
CurDist = Abs(CurNum - TestNum)
If CurDist < WinningDist Then
WinningDist = CurDist
WinningObj = X
End If
Next X
ReturnClosestIndexInArray = WinningObj
End Function
Return Closest Number In Array
Function ReturnClosestNumberInArray(SampleArr As Variant, TestNum As
Variant) As Double
Dim WinningDist As Double
WinningDist = 100000023
Dim WinningObj
For X = 0 To UBound(SampleArr)
Dim CurNum
CurNum = SampleArr(X)
Dim CurDist As Double
CurDist = Abs(CurNum - TestNum)
If CurDist < WinningDist Then
WinningDist = CurDist
WinningObj = SampleArr(X)
End If
Next X
ReturnClosestNumberInArray = WinningObj
End Function
Reverse Array
Function ReverseArray(SampleArr) As Variant
Dim TempArr()
ReDim TempArr(UBound(SampleArr))
For X = 0 To UBound(SampleArr)
If IsEmpty(SampleArr(UBound(SampleArr) - X)) = False Then
TempArr(X) = SampleArr(UBound(SampleArr) - X)
End If
Next X
ReverseArray = TempArr
End Function
Round Values In Array
Function RoundValuesInArray(SampArr As Variant, DivisorVal As Double)
As Variant
For X = 0 To UBound(SampArr)
Dim TempNum3 As Double
TempNum3 = Int(SampArr(X) / DivisorVal) * DivisorVal
SampArr(X) = TempNum3
Next X
RoundValuesInArray = SampArr
End Function
Sort 2 Arrays
Public Function Sort2Arrays(ByRef TheArray As Variant, ByRef
TheSecondArray As Variant)
Sorted = False
Do While Not Sorted
Sorted = True
For X = 0 To UBound(TheArray) - 1
If TheArray(X) > TheArray(X + 1) Then
Temp2 = TheSecondArray(X + 1)
Temp = TheArray(X + 1)
TheSecondArray(X + 1) = TheSecondArray(X)
TheArray(X + 1) = TheArray(X)
TheSecondArray(X) = Temp2
TheArray(X) = Temp
Sorted = False
End If
Next X
Loop
End Function
Sort Array
Public Function SortArray(ByRef TheArray As Variant)
Sorted = False 'Public Code from non-GT site.
Do While Not Sorted
Sorted = True
For X = 0 To UBound(TheArray) - 1
If TheArray(X) < TheArray(X + 1) Then
Temp = TheArray(X + 1)
TheArray(X + 1) = TheArray(X)
TheArray(X) = Temp
Sorted = False
End If
Next X
Loop
End Function
Excel Functions
Check Excel Duplicates
Function CheckExcelDuplicates(ColumnNo As Integer, EndRow As Integer,
CheckEmptyStrings As Boolean) As Boolean
Dim ColStrArr()
ReDim ColStrArr(0)
For X = 1 To EndRow
Dim XCounter As Integer
XCounter = 0
Dim CurCellStr As String
CurCellStr = CStr(CurCells(X, ColumnNo).Value)
While XCounter < UBound(ColStrArr)
If ColStrArr(XCounter) = CurCellStr Then
CheckExcelDuplicates = True
CurCells(X, ColumnNo).Font.colorindex = 41
Exit Function
End If
XCounter = XCounter + 1
Wend
If CheckEmptyStrings = False And CurCellStr = "" Then
Else
ColStrArr(UBound(ColStrArr)) = CurCellStr
ReDim Preserve ColStrArr(UBound(ColStrArr) + 1)
End If
Next X
End Function
Export Pt Coord to XLS
Sub ExportPtCoordToXLS(CurPtObj As Variant)
If IsUpdatable(CurPtObj) Then
Dim CIMeas
Set CIMeas = TheSPAWorkbench.GetMeasurable(CurPtObj)
Dim CICoords()
ReDim CICoords(2)
CIMeas.GetPoint CICoords
CurCells(CSVCounter, 1).Value = CurPtObj.Name
CurCells(CSVCounter, 2).Value = CICoords(0)
CurCells(CSVCounter, 3).Value = CICoords(1)
CurCells(CSVCounter, 4).Value = CICoords(2)
CSVCounter = CSVCounter + 1
End If
End Sub
Get First Instance in Excel
Function GetFirstInstanceInExcel(InputVal As String, ColumnNo As
Integer, EndRow As Integer) As Integer
Dim LCounter As Integer
LCounter = 2
While LCounter <= EndRow
CurCellStr = CStr(CurCells(LCounter, ColumnNo).Value)
If CurCellStr = InputVal Then
GetFirstInstanceInExcel = LCounter
Exit Function
End If
LCounter = LCounter + 1
Wend
GetFirstInstanceInExcel = -1
End Function
Is App Open
Function IsAppOpen(AppName As String) As Boolean
On Error GoTo Blast
Set MyApp = GetObject(, AppName & ".Application")
IsAppOpen = True
Exit Function
Blast:
IsAppOpen = False
End Function
Return Total Rows
Function ReturnTotalRows() As Integer
Dim RowCounter As Integer
RowCounter = 1
Dim FileCheck As Boolean
FileCheck = False
While RowCounter < 1000 And FileCheck = False
FileCheck = True
For colcounter = 1 To 15
If CurCells(RowCounter, colcounter) <> "" Then
FileCheck = False
End If
Next colcounter
RowCounter = RowCounter + 1
Wend
ReturnTotalRows = RowCounter
End Function]
Spaces Below
Function SpacesBelow(RowNum As Variant, ColNum As Variant) As Integer
Dim RC As Integer
RC = 0
Dim CurName As String
CurName = CurCells(RowNum, ColNum)
While CurName = "" And RowNum + RC <= TotalRows + 1
CurName = CStr(CurCells(RowNum + RC, ColNum).Value)
RC = RC + 1
Wend
SpacesBelow = RC - 1
End Function
Geometrical Set Functions
Add Set If Not There
Function AddSetIfNotThere(ContainerSet As Variant, HBName As String)
As HybridBody
Dim JKL As HybridBody
If ContainerSet.HybridBodies.Count = 0 Then
Set JKL = ContainerSet.HybridBodies.Add
JKL.Name = HBName
Set AddSetIfNotThere = JKL
Exit Function
End If
Dim SetCounter As Integer
SetCounter = 1
While SetCounter <= ContainerSet.HybridBodies.Count
If ContainerSet.HybridBodies.Item(SetCounter).Name = HBName Then
Set JKL = ContainerSet.HybridBodies.Item(HBName)
Set AddSetIfNotThere = JKL
Exit Function
End If
SetCounter = SetCounter + 1
Wend
Set JKL = ContainerSet.HybridBodies.Add
JKL.Name = HBName
Set AddSetIfNotThere = JKL
End Function
Delete Duplicate Hybrid Shapes in Geom Set
Sub DeleteDuplicateHybridShapesInGeomSet(geom_set As HybridBody,
cur_part As Part, cur_HSF As HybridShapeFactory)
Dim numb_set As Integer
numb_set = geom_set.HybridShapes.Count
Dim array_1()
ReDim array_1(numb_set - 1)
Dim loop1 As Integer
For loop1 = 0 To (numb_set - 1)
Set array_1(loop1) = geom_set.HybridShapes.Item(loop1 + 1)
Next loop1
Dim loop2 As Integer
For loop2 = 0 To (numb_set - 1)
Dim compare_obj1 As HybridShape
If IsEmpty(array_1(loop2)) = False Then
Set compare_obj1 = array_1(loop2)
Dim compare_obj2 As HybridShape
Dim loop3 As Integer
For loop3 = 0 To (numb_set - 1)
If IsEmpty(array_1(loop3)) = False Then
Set compare_obj2 = array_1(loop3)
If compare_obj1.Name = compare_obj2.Name Then
ElseIf CheckIfTwoObjectsAreDuplicates(compare_obj1,
compare_obj2, cur_part, cur_HSF, geom_set) = True Then
MyHSFactory.DeleteObjectForDatum compare_obj2
End If
End If
Next loop3
End If
Next loop2
End Sub
Delete Non Surfaces (from Geom Set)
Sub DeleteNonSurfaces(InputHS As Variant)
Dim ObjArr()
ReDim ObjArr(InputHS.HybridShapes.Count - 1)
For X = 0 To InputHS.HybridShapes.Count - 1
Set ObjArr(X) = InputHS.HybridShapes.Item(X + 1)
Next
For Inputcounter = 1 To UBound(ObjArr)
Dim KObj
Set KObj = ObjArr(Inputcounter - 1)
Dim KMeas
Set KMeas = TheSPAWorkbench.GetMeasurable(KObj)
If KMeas.GeometryName <> CatMeasurableSurface Then
MyHSFactory.DeleteObjectForDatum KObj
End If
Next
Exit Sub
End Sub
Find Closest Object in Geom Set
Function FindClosestObjectInGeomSet(GeomSet As HybridBody, CurrentPt
As Variant) As Variant
Dim WinningDist As Double
WinningDist = 1000000000
Dim CMeas 'As Measurable
Set CMeas = theSPAWorkbench.GetMeasurable(CurrentPt)
For xxx = 1 To GeomSet.HybridShapes.Count
Dim CurLine 'As HybridShape
Set CurLine = GeomSet.HybridShapes.Item(xxx)
Dim TempDist As Double
TempDist = CMeas.GetMinimumDistance(CurLine)
If TempDist < WinningDist Then
WinningDist = TempDist
Set winningObj = CurLine
End If
Next xxx
Set FindClosestObjectInGeomSet = winningObj
End Function
Find Obj by String in Geom Set
Function FindObjByStringInGeomSet(GeoSet As HybridBody, StrSeg As
String) As HybridShape
Dim numb_set As Integer
numb_set = GeoSet.HybridShapes.Count
Dim loop_x As Integer
For loop_x = 1 To numb_set
If InStr(GeoSet.HybridShapes.Item(loop_x).Name, StrSeg) <> 0 Then
Set FindObjByStringInGeomSet =
GeoSet.HybridShapes.Item(loop_x)
loop_x = numb_set
End If
Next loop_x
End Function
Hybrid Shape Exists in Hybrid Body
Function HybridShapeExistsInHybridBody(InputStr As String, CurSet as
HybridBody) As Boolean
On Error GoTo blast
Set HHH = CurSet.HybridShapes.Item(InputStr)
HybridShapeExistsInHybridBody = True
Exit Function
blast:
HybridShapeExistsInHybridBody = False
End Function
Remove Blank Set
Sub RemoveBlankSet(NewPart As Variant)
If NewPart.HybridBodies.Count = 0 Then
Exit Sub
End If
If NewPart.HybridBodies.Item(1).Name = "Geometrical Set.1" And
NewPart.HybridBodies.Item(1).HybridShapes.Count = 0 Then
If MySel.Count <> 0 Then
MySel.Clear
End If
MySel.Add NewPart.HybridBodies.Item(1)
MySel.Delete
End If
End Sub
Return Axis from Set
Function ReturnAxisFromSet(HB As HybridBody) As AxisSystem
Dim CurParms As Parameters
Set CurParms = MyPart.Parameters.SubList(HB, True)
Dim FirstParm As Parameter
Set FirstParm = FindFirstAxisParmInParms(CurParms)
Dim AxisPath As String
AxisPath = FirstParm.Name
AxisNameArr = Split(AxisPath, "\")
Dim AxisName As String
AxisName = AxisNameArr(UBound(AxisNameArr) - 2)
Dim CurAxisInSet As AxisSystem
Set CurAxisInSet = ReturnAxisSysFromArrayByName(AxisArr, AxisName)
'Global declaration: AxisArr = MakeArrayFromSearch("Type='Part
Design'.'Axis System',all")
Set ReturnAxisFromSet = CurAxisInSet
End Function
Return Intersecting Object from Set
Function ReturnIntersectingObjectFromSet(SampleSet As HybridBody,
CurObj As Variant) As Variant
For X = 1 To SampleSet.HybridShapes.Count
Dim CurSamp
Set CurSamp = SampleSet.HybridShapes.Item(X)
If CheckIntersection(CurSamp, CurObj, MyPart) Then
Set ReturnIntersectingObjectFromSet = CurSamp
Exit Function
End If
Next X
End Function
Set Axis Systems ToI n Geom Set
Sub SetAxisSystemsToInGeomSet()
Set MyPart = CATIA.ActiveDocument.Part
Set MySel = CATIA.ActiveDocument.Selection
Dim NewAxis As AxisSystem
Set NewAxis = MyPart.AxisSystems.Add
MyPart.UpdateObject NewAxis
If MySel.Count <> 0 Then
MySel.Clear
End If
If HasParent(NewAxis) Then
'In Axis System
CATIA.StartCommand "Axis System"
CATIA.RefreshDisplay = True
SendKeys "{Tab 9}", True
SendKeys " "
SendKeys "{Enter}", True
CATIA.RefreshDisplay = True
'9-tabs + space + enter
MySel.Add MyPart.InWorkObject
MySel.Search "Name='Axis System.'*,sel"
Dim CurAxisObj
Set CurAxisObj = MySel.Item(MySel.Count).Value
If MySel.Count <> 0 Then
MySel.Clear
End If
MySel.Add CurAxisObj
Else
'In Geom Set
End If
MySel.Add NewAxis
MySel.Delete
End Sub
Set External References as Visible
Sub SetExternalReferencesAsVisible(True_or_False As Boolean)
Dim SetCont As SettingControllers
Set SetCont = CATIA.SettingControllers
Dim PartAtt As PartInfrastructureSettingAtt
Set PartAtt = SetCont.Item("CATMmuPartInfrastructureSettingCtrl")
PartAtt.ExternalReferencesAsVisible = True_or_False
End Sub
Geometry Functions
Add Louvre with End Offset By Curve from Origin Axis
Function AddLouvreWithEndOffsetByCurveFromOriginAxis(SketchProfileREF
As Reference, GuideCurve As Variant, OffsetDim As Double, ConstSet As
HybridBody, FinalSet As HybridBody) As HybridShapeSweepExplicit
Dim EndPt1 As HybridShapePointOnCurve
Set EndPt1 =
MyHSFactory.AddNewPointOnCurveFromDistance(GuideCurve, OffsetDim,
True)
ConstSet.AppendHybridShape EndPt1
MyHSFactory.GSMVisibility EndPt1, 0
Dim EndPt3 As HybridShapePointOnCurve
Set EndPt3 =
MyHSFactory.AddNewPointOnCurveFromDistance(GuideCurve, OffsetDim,
False)
ConstSet.AppendHybridShape EndPt3
MyHSFactory.GSMVisibility EndPt3, 0
Dim MSupSpl1 As HybridShapeSplit
Set MSupSpl1 = MyHSFactory.AddNewHybridSplit(GuideCurve, EndPt3,
1)
MSupSpl1.AddElementToKeep EndPt1
ConstSet.AppendHybridShape MSupSpl1
MyHSFactory.GSMVisibility MSupSpl1, 0
Dim MSupSpl2 As HybridShapeSplit
Set MSupSpl2 = MyHSFactory.AddNewHybridSplit(MSupSpl1, EndPt1, 1)
MSupSpl2.AddElementToKeep EndPt3
ConstSet.AppendHybridShape MSupSpl2
MyHSFactory.GSMVisibility MSupSpl2, 0
Dim MSupFirstPt As HybridShapePointOnCurve
Set MSupFirstPt =
MyHSFactory.AddNewPointOnCurveFromPercent(MSupSpl2, 0, True)
ConstSet.AppendHybridShape MSupFirstPt
'MyHSFactory.GSMVisibility MSupFirstPt, 0
Dim MSubStartDirLin As HybridShapeLineTangency
Set MSubStartDirLin = MyHSFactory.AddNewLineTangency(MSupSpl2,
MSupFirstPt, 0, 25.4, True)
ConstSet.AppendHybridShape MSubStartDirLin
MyPart.UpdateObject MSubStartDirLin
'MyHSFactory.GSMVisibility MSubStartDirLin, 0
Dim MSubNormPlane As HybridShapeLineNormal 'As
HybridShapePlane2Lines
Set MSubNormPlane = MyHSFactory.AddNewLineNormal(DriverSrf,
MSupFirstPt, 0, 10, True) 'AddNewPlane2Lines(MSubStartDirLin,
Zaxis)
ConstSet.AppendHybridShape MSubNormPlane
MyPart.UpdateObject MSubNormPlane
'MyHSFactory.GSMVisibility MSubNormPlane, 0
Dim MSub2LinesPlane As HybridShapePlane2Lines
Set MSub2LinesPlane =
MyHSFactory.AddNewPlane2Lines(MSubStartDirLin, MSubNormPlane)
ConstSet.AppendHybridShape MSub2LinesPlane
MyPart.UpdateObject MSub2LinesPlane
'MyHSFactory.GSMVisibility MSub2LinesPlane, 0
Dim axisSystems1 As AxisSystems
Set axisSystems1 = MyPart.AxisSystems
Dim axisSystem1 As AxisSystem
Set axisSystem1 = axisSystems1.Add()
axisSystem1.OriginType = catAxisSystemOriginByPoint
axisSystem1.OriginPoint = MSupFirstPt
axisSystem1.XAxisType = catAxisSystemAxisOppositeDirection
axisSystem1.XAxisDirection = MSubNormPlane
axisSystem1.YAxisType = catAxisSystemAxisOppositeDirection
'Dim hybridShapePlaneExplicit1 As HybridShapePlaneExplicit
'Set hybridShapePlaneExplicit1 = MyPart.OriginElements.PlaneXY
'axisSystem1.YAxisDirection = hybridShapePlaneExplicit1
axisSystem1.YAxisDirection = MSub2LinesPlane
axisSystem1.ZAxisType = catAxisSystemAxisSameDirection
axisSystem1.ZAxisDirection = MSubStartDirLin
'SafeHide axisSystem1 'x flips
Dim MainAxisSysREF As Reference
Set MainAxisSysREF = MyPart.CreateReferenceFromObject(MainAxisSys)
Dim axisSystem1REF As Reference
Set axisSystem1REF = MyPart.CreateReferenceFromObject(axisSystem1)
Dim NAxis2Axis As HybridShapeAxisToAxis
Set NAxis2Axis = MyHSFactory.AddNewAxisToAxis(SketchProfileREF,
MainAxisSysREF, axisSystem1REF)
ConstSet.AppendHybridShape NAxis2Axis
'MyHSFactory.GSMVisibility NAxis2Axis, 0
Dim LouvreSweep As HybridShapeSweepExplicit
Set LouvreSweep = MyHSFactory.AddNewSweepExplicit(NAxis2Axis,
MSupSpl2)
LouvreSweep.SubType = 1
LouvreSweep.Reference = MyPart.OriginElements.PlaneXY
LouvreSweep.SetAngleRef 1, 0#
LouvreSweep.SolutionNo = 0
LouvreSweep.SmoothActivity = False
LouvreSweep.GuideDeviationActivity = False
FinalSet.AppendHybridShape LouvreSweep
'MyPart.UpdateObject LouvreSweep
LouvreSweep.Name = GuideCurve.Name & "_MULLGEOM"
'MoveAxisSystemXDirFartherFromCoord axisSystem1, LouvreSweep, 0,
0, 0
Set AddLouvreByCurveFromOriginAxis = LouvreSweep
IsUpdatable LouvreSweep
End Function
Batch Extrude From Selection
Sub BatchExtrudeFromSelection()
Dim MyPart As Part
Dim MyHSFactory As HybridShapeFactory
Dim MySel As Selection
Set MyPart = CATIA.ActiveDocument.Part
Set MySel = CATIA.ActiveDocument.Selection
Set MyHSFactory = MyPart.HybridShapeFactory
If MySel.Count = 0 Then
Exit Sub
End If
Dim CurSet As HybridBody
Set CurSet = MyPart.InWorkObject
Dim Zaxis As HybridShapeDirection
Set Zaxis = MyHSFactory.AddNewDirectionByCoord(0, 0, 1)
For X = 1 To MySel.Count
CATIA.StatusBar = "Completed... " & Round((X / MySel.Count) *
100, 0)
Dim CurExt As HybridShapeExtrude
Set CurExt = MyHSFactory.AddNewExtrude(MySel.Item(X).Value, 0, -42
* 25.4, Zaxis)
CurSet.AppendHybridShape CurExt
CurExt.Name = MySel.Item(X).Value.Name & "_EXT"
Next
MyPart.Update
End Sub
Fillet Stabilizer
Function FilletStabilizer(CurveBefore As Variant, CurveAfter As
Variant, InPlane As Variant, FilletRad As Double, GeomSet As
HybridBody, SurfName As String) As Boolean
FilletStabilizer = True
Dim MyPart As Part
Set MyPart = CATIA.ActiveDocument.Part
Dim MyHSFactory As HybridShapeFactory
Set MyHSFactory = MyPart.HybridShapeFactory
Dim FilletObj As HybridShapeCircleBitangentRadius
Set FilletObj = MyHSFactory.AddNewCircleBitangentRadius(CurveBefore,
CurveAfter, Nothing, FilletRad, 1, 1)
FilletObj.DiscriminationIndex = 1
'DestSet.AppendHybridShape FilletObj
FilletObj.BeginOfCircle = 2
FilletObj.SetLimitation 2
FilletObj.TrimMode = 0
'FilletObj.EndAngle = 180
'FilletObj.StartAngle = 0
GeomSet.AppendHybridShape FilletObj
FilletObj.Name = SurfName & "Fillet_edge_line"
Dim FC As Boolean
FC = False
Dim SuperMatrix
ReDim SuperMatrix(15)
SuperMatrix(0) = Array(1, 1, 1, 1)
SuperMatrix(1) = Array(-1, 1, 1, 1)
SuperMatrix(2) = Array(1, -1, 1, 1)
SuperMatrix(3) = Array(-1, -1, 1, 1) '
SuperMatrix(4) = Array(1, 1, -1, 1)
SuperMatrix(5) = Array(-1, 1, -1, 1)
SuperMatrix(6) = Array(1, -1, -1, 1)
SuperMatrix(7) = Array(-1, -1, -1, 1) '
SuperMatrix(8) = Array(1, 1, 1, -1)
SuperMatrix(9) = Array(-1, 1, 1, -1)
SuperMatrix(10) = Array(1, -1, 1, -1)
SuperMatrix(11) = Array(-1, -1, 1, 1) '
SuperMatrix(12) = Array(1, 1, -1, -1)
SuperMatrix(13) = Array(-1, 1, -1, -1)
SuperMatrix(14) = Array(1, -1, -1, -1)
SuperMatrix(15) = Array(-1, -1, -1, -1)
Dim FCCounter As Integer
FCCounter = 0
While FC = False And FCCounter < 16
FC = FilletCheck(FilletObj, SuperMatrix(FCCounter)(0),
SuperMatrix(FCCounter)(1),SuperMatrix(FCCounter)(2),
SuperMatrix(FCCounter)(3))
FCCounter = FCCounter + 1
Wend
If FC = False Then
FilletStabilizer = False
Exit Function
End If
'FilletObj.Support = inplane
MyPart.InWorkObject = FilletObj
MyPart.UpdateObject FilletObj
End Function
Line from Arc End Pts
Function LineFromArcEndPts(ArcCrv As Variant, ConstSet As HybridBody,
DestSet As HybridBody) As HybridShapeLinePtPt
If CrvCheck(ArcCrv) Then
Dim BPt As HybridShapePointOnCurve
Set BPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 0, True)
ConstSet.AppendHybridShape BPt
BPt.Name = ArcCrv.Name & "_BPT"
MyHSFactory.GSMVisibility BPt, 0
Dim EPt As HybridShapePointOnCurve
Set EPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 1, True)
ConstSet.AppendHybridShape EPt
EPt.Name = ArcCrv.Name & "_EPT"
MyHSFactory.GSMVisibility EPt, 0
Dim LineObj As HybridShapeLinePtPt
Set LineObj = MyHSFactory.AddNewLinePtPt(BPt, EPt)
DestSet.AppendHybridShape LineObj
LineObj.Name = ArcCrv.Name & "_FINLINE"
IsUpdatable LineObj
Set LineFromArcEndPts = LineObj
End If
End Function
Make Tangent Line at Pt
Sub MakeTangentLineAtPt(InputCrv As Variant, EndPt As Variant, DestSet
As HybridBody)
Dim TangLine As HybridShapeLineTangency
Set TangLine = MyHSFactory.AddNewLineTangency(InputCrv, EndPt, 0, 100,
True)
DestSet.AppendHybridShape TangLine
TangLine.Name = InputCrv.Name & "_TANGLINE"
IsUpdatable TangLine
Dim Tmeas
Set Tmeas = TheSPAWorkbench.GetMeasurable(InputCrv)
Dim PtCoords(8)
Tmeas.GetPointsOnCurve PtCoords
MoveLineTangencyCloserToCoord TangLine, CDbl(PtCoords(3)),
CDbl(PtCoords(4)), CDbl(PtCoords(5))
IsUpdatable TangLine
ForceColorObjUgly TangLine, 30, 230, 100, 6, 1000, 1, 1000
End Sub
Match Blend Orientations with End Pts
Sub MatchBlendOrientations(InputBlend As HybridShapeBlend)
Dim Curve1
Set Curve1 =
MyHSFactory.GSMGetObjectFromReference(InputBlend.GetCurve(1))
Dim Curve2
Set Curve2 =
MyHSFactory.GSMGetObjectFromReference(InputBlend.GetCurve(2))
IsUpdatable Curve1
Dim C1Meas
Set C1Meas = TheSPAWorkbench.GetMeasurable(Curve1)
Dim C1Coords()
ReDim C1Coords(8)
C1Meas.GetPointsOnCurve C1Coords
IsUpdatable Curve2
Dim C2Meas
Set C2Meas = TheSPAWorkbench.GetMeasurable(Curve2)
Dim C2Coords()
ReDim C2Coords(8)
C2Meas.GetPointsOnCurve C2Coords
Dim FirstDist As Double
FirstDist = find3DDistance(C1Coords(0), C1Coords(1), C1Coords(2),
C2Coords(0), C2Coords(1), C2Coords(2))
Dim SecondDist As Double
SecondDist = find3DDistance(C1Coords(0), C1Coords(1), C1Coords(2),
C2Coords(6), C2Coords(7), C2Coords(8))
If FirstDist > SecondDist Then
InputBlend.SetOrientation 1, 1
InputBlend.SetOrientation 2, -1
End If
End Sub
Poly Line from Arc Pts
Function PolyLineFromArcPts(ArcCrv As Variant, ConstSet As HybridBody,
DestSet As HybridBody) As HybridShapePolyline
If CrvCheck(ArcCrv) Then
Dim BPt As HybridShapePointOnCurve
Set BPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 0, True)
ConstSet.AppendHybridShape BPt
BPt.Name = ArcCrv.Name & "_BPT"
MyHSFactory.GSMVisibility BPt, 0
Dim MPt As HybridShapePointOnCurve
Set MPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 0.5, True)
ConstSet.AppendHybridShape MPt
MPt.Name = ArcCrv.Name & "_MPT"
MyHSFactory.GSMVisibility MPt, 0
Dim EPt As HybridShapePointOnCurve
Set EPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 1, True)
ConstSet.AppendHybridShape EPt
EPt.Name = ArcCrv.Name & "_EPT"
MyHSFactory.GSMVisibility EPt, 0
Dim LineObj As HybridShapePolyline
Set LineObj = MyHSFactory.AddNewPolyline()
LineObj.InsertElement BPt, 1
LineObj.InsertElement MPt, 2
LineObj.InsertElement EPt, 3
DestSet.AppendHybridShape LineObj
LineObj.Name = ArcCrv.Name & "_FINPLINE"
IsUpdatable LineObj
Set PolyLineFromArcPts = LineObj
End If
End Function
Return Closest Point
Function ReturnClosestPoint(StartPoint As Variant, Point1 As Variant, Point2 As Variant) As
Variant
MyPart.UpdateObject StartPoint
MyPart.UpdateObject Point1
MyPart.UpdateObject Point2
Dim CMeas
Set CMeas = TheSPAWorkbench.GetMeasurable(StartPoint)
Dim Dist1, Dist2 As Double
Dist1 = CMeas.GetMinimumDistance(Point1)
Dist2 = CMeas.GetMinimumDistance(Point2)
Dim RCP()
ReDim RCP(1)
If Dist1 < Dist2 Then
Set RCP(0) = Point1
Set RCP(1) = Point2
Else
Set RCP(0) = Point2
Set RCP(1) = Point1
End If
ReturnClosestPoint = RCP
End Function
Std Arc from Arc End Pts
Function StdArcFromArcEndPts(ArcCrv As Variant, StdRadVal As Double,
ConstSet As HybridBody, DestSet As HybridBody) As
HybridShapeCircle2PointsRad
If CrvCheck(ArcCrv) Then
Dim BPt As HybridShapePointOnCurve
Set BPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 0, True)
ConstSet.AppendHybridShape BPt
BPt.Name = ArcCrv.Name & "_BPT"
MyHSFactory.GSMVisibility BPt, 0
Dim MPt As HybridShapePointOnCurve
Set MPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 0.5, True)
ConstSet.AppendHybridShape MPt
MPt.Name = ArcCrv.Name & "_MPT"
MyHSFactory.GSMVisibility MPt, 0
Dim EPt As HybridShapePointOnCurve
Set EPt = MyHSFactory.AddNewPointOnCurveFromPercent(ArcCrv, 1, True)
ConstSet.AppendHybridShape EPt
EPt.Name = ArcCrv.Name & "_EPT"
MyHSFactory.GSMVisibility EPt, 0
Dim CurPlane As HybridShapePlane3Points
Set CurPlane = MyHSFactory.AddNewPlane3Points(BPt, MPt, EPt)
ConstSet.AppendHybridShape CurPlane
CurPlane.Name = ArcCrv.Name & "_CP"
MyHSFactory.GSMVisibility CurPlane, 0
Dim LineObj As HybridShapeCircle2PointsRad
Set LineObj = MyHSFactory.AddNewCircle2PointsRad(BPt, EPt, CurPlane,
False, StdRadVal, 1)
DestSet.AppendHybridShape LineObj
LineObj.Name = ArcCrv.Name & "_FINLINE"
IsUpdatable LineObj
MoveCircle2PointsRadCloserToObj LineObj, MPt
Set StdArcFromArcEndPts = LineObj
End If
End Function
Tension Relief
Sub TensionRelief(InputSpline As Variant, IntersectionCurve As
Variant)
CATIA.ActiveDocument.Part.UpdateObject InputSpline
Dim Meas
Set Meas = TheSPAWorkbench.GetMeasurable(InputSpline)
Dim LLength As Double
LLength = Meas.Length
InputSpline.SetPointConstraintFromCurve 1, IntersectionCurve, -1#, -1,
1
CATIA.ActiveDocument.Part.UpdateObject InputSpline
Dim Meas2
Set Meas2 = TheSPAWorkbench.GetMeasurable(InputSpline)
Dim LLength2 As Double
LLength2 = Meas2.Length
If LLength < LLength2 Then
InputSpline.SetPointConstraintFromCurve 1, IntersectionCurve, 1#,
-1, 1
CATIA.ActiveDocument.Part.UpdateObject InputSpline
End If
End Sub
Math Functions
Angle between two planes - Dihedral Angle
Public Function DihedralAngle(FirstPlane As iPlan, SecondPlane As
iPlan) As Double
DihedralAngle = ArcCos(FirstPlane.Ax * SecondPlane.Ax + FirstPlane.By
* SecondPlane.By + FirstPlane.Cz * SecondPlane.Cz / _
Sqr((FirstPlane.Ax ^ 2 + FirstPlane.By ^ 2 + FirstPlane.Cz ^ 2) *
(SecondPlane.Ax ^ 2 + SecondPlane.By ^ 2 + SecondPlane.Cz ^ 2)))
End Function
Arcos
Public Function ArcCos(Radians As Double) As Double
If Round(Radians, 8) = 1 Then ArcCos = 0: Exit Function
If Round(Radians, 8) = -1 Then ArcCos = PI: Exit Function
ArcCos = Atn(-Radians / Sqr(1 - Radians ^ 2)) + 2 * Atn(1)
End Function
ArcSin
Public Function ArcSin(Radians As Double) As Double
If (Sqr(1 - Radians ^ 2) <= 0.000000000001) And (Sqr(1 - Radians ^ 2)
>= -0.000000000001) Then
ArcSin = PI / 2
Else
ArcSin = Atn(Radians / Sqr(1 - Radians ^ 2))
End If
End Function
Color to RGB
Function Color_to_RGB(Color As Long) As Variant
Dim CurRGB() As Integer
ReDim CurRGB(2)
CurRGB(0) = Color Mod 256
CurRGB(1) = (Color \ 256) Mod 256
CurRGB(2) = (Color \ 256 \ 256) Mod 256
Color_to_RGB = CurRGB
End Function
Cross Product
Function CrossProduct(PtAx As Double, PtAy As Double, PtAz As Double,
PtBx As Double, PtBy As Double, PtBz As Double, PtCx As Double, PtCy
As Double, PtCz As Double) As Variant
Dim Vec1()
ReDim Vec1(2)
Dim Vec2()
ReDim Vec2(2)
Vec1(0) = PtAx - PtBx
Vec1(1) = PtAy - PtBy
Vec1(2) = PtAz - PtBz
Vec2(0) = PtCx - PtBx
Vec2(1) = PtCy - PtBy
Vec2(2) = PtCz - PtBz
'Ax As Double, Ay As Double, Az As Double, Bx As Double, By As Double,
Bz As Double
Dim CrossArr()
ReDim CrossArr(2)
CrossArr(0) = Vec1(1) * Vec2(2) - Vec2(1) * Vec1(2)
CrossArr(1) = Vec1(2) * Vec2(0) - Vec2(2) * Vec1(0)
CrossArr(2) = Vec1(0) * Vec2(1) - Vec2(0) * Vec1(1)
CrossProduct = CrossArr
End Function
Dec 2 Fract
Function Dec2Fract(X As Single) As String
Dim F As String, Y As Single, Num As Integer, Den As Integer
Den = 16 'Denominator: can be set to 8, 16, 32, 64 etc
If X = 0 Then
Dec2Fract = ""
Exit Function
Else
Y = Abs(X)
If Y > 1 Then Y = Y - Int(Y) ' get fractional part
Num = CInt(Den * Y)
If Num = Den Then
F = "1"
ElseIf Num = 0 Then
If Abs(X) < 1 Then F = "0" Else F = ""
Else
Do Until Num Mod 2 <> 0
Num = Num / 2
Den = Den / 2
Loop
F = LTrim$(Str$(Num)) + "/" + LTrim$(Str$(Den))
End If
If Abs(X) > 1 Then
If F <> "1" Then
F = Trim$(Str$(Fix(X))) + " " + F
Else
F = Trim$(Str$(CInt(X)))
End If
End If
If X < 0 And X > -1 Then F = "-" + F
Dec2Fract = F
End If
End Function
Deg to rad
Function deg_to_rad(InputDegrees As Double) As Double
deg_to_rad = InputDegrees * 3.14159265 / 180
End Function
Determinant of an NxN matrix
Public Function GetDet(M() As Double) As Double
Dim i As Integer: Dim j As Integer
Dim Size As Integer: Size = UBound(M): Dim RetVal As Double
If Size = 1 Then
RetVal = RetVal + M(0, 0) * M(1, 1) - M(0, 1) * M(1, 0) 'daca e
deteminant 2x2
Else
For i = 0 To Size
RetVal = RetVal + ((-1) ^ i) * M(0, i) * GetDet(GetMinor(M, 0, i))
'daca e determinant NxN
Next
End If
GetDet = RetVal
End Function
Minor matrix - it is used to calculate the determinant of an NxN matrix
Public Function GetMinor(Min() As Double, RemRow As Integer, RemCol As
Integer) As Double()
Dim RetVal() As Double: Dim i As Integer: Dim j As Integer
Dim IdxC As Integer: Dim IdxR As Integer
Dim Size As Integer: IdxR = 0: Size = UBound(Min) - 1
ReDim RetVal(Size, Size) As Double
For i = 0 To Size + 1
If i <> RemRow Then
IdxC = 0
For j = 0 To Size + 1
If j <> RemCol Then
RetVal(IdxR, IdxC) = Min(i, j)
IdxC = IdxC + 1
End If
Next
IdxR = IdxR + 1
End If
Next
GetMinor = RetVal
Erase RetVal
End Function
Distance between two points
Public Function P2PDist(FirstPoint As iPct, SecondPoint As iPct) As
Double
Distance = Sqr((SecondPoint.X - FirstPoint.X) ^ 2 + (SecondPoint.Y -
FirstPoint.Y) ^ 2 + (SecondPoint.Z - FirstPoint.Z) ^ 2)
End Function
Distance from Equation of Line
Function DistanceFromEquationOfLine(LineSlope As Variant,
Line_Y_Intersept As Variant, Pt_X_Coord As Double, Pt_Y_Coord As
Double) As Double
DistanceFromEquationOfLine = Abs(Pt_Y_Coord - (LineSlope * Pt_X_Coord)
- Line_Y_Intersept) / Sqr((LineSlope * LineSlope) + 1)
End Function
Dot Product
Function DotProduct(U, V)
temp = U(0) * V(0) + U(1) * V(1) + U(2) * V(2)
DotProduct = temp
End Function
Find 3D Distance
Function find3DDistance(Xdim As Variant, Ydim As Variant, Zdim As
Variant, X2dim As Variant, Y2Dim As Variant, Z2Dim As Variant) As
Double
find3DDistance = Sqr(((Xdim - X2dim) * (Xdim - X2dim)) + ((Ydim -
Y2Dim) * (Ydim - Y2Dim)) + ((Zdim - Z2Dim) * (Zdim - Z2Dim)))
End Function
Get Acute Angle
Function GetAcuteAngle(Line1 As Variant, Line2 As Variant) As Double
Dim AMeas
Set AMeas = TheSPAWorkBench.GetMeasurable(Line1)
Dim AAng As Double
AAng = AMeas.GetAngleBetween(Line2)
If AAng > 135 Then
GetAcuteAngle = 180 - AAng
Else
GetAcuteAngle = AAng
End If
End Function
Get Angle Between
Function GetAngleBetween(PtAx As Variant, PtAy As Variant, PtAz As
Variant, PtBx As Variant, PtBy As Variant, PtBz As Variant, PtCx As
Variant, PtCy As Variant, PtCz As Variant) As Double
Dim Vec1()
ReDim Vec1(2)
Dim Vec2()
ReDim Vec2(2)
Vec1(0) = PtAx - PtBx
Vec1(1) = PtAy - PtBy
Vec1(2) = PtAz - PtBz
Vec2(0) = PtCx - PtBx
Vec2(1) = PtCy - PtBy
Vec2(2) = PtCz - PtBz
Length1 = Sqr(Vec1(0) * Vec1(0) + Vec1(1) * Vec1(1) + Vec1(2) *
Vec1(2))
Length2 = Sqr(Vec2(0) * Vec2(0) + Vec2(1) * Vec2(1) + Vec2(2) *
Vec2(2))
DotP = (Vec1(0) * Vec2(0) + Vec1(1) * Vec2(1) + Vec1(2) * Vec2(2))
Calc = DotP / (Length1 * Length2)
'Arccos (77)
GetAngleBetween = (Atn(-Calc / Sqr(-Calc * Calc + 1)) + 2 * Atn(1)) *
(180 / PI)
End Function
Get Distance
Function GetDistance(EdgeRef1, EdgeRef2)
Dim CurrentMeasurable ' As Measurable
Set TheSPAWorkBench =
CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")
Dim TempDistance
Set CurrentMeasurable = TheSPAWorkBench.GetMeasurable(EdgeRef1)
TempDistance = CurrentMeasurable.GetMinimumDistance(EdgeRef2)
GetDistance = TempDistance
End Function
Get Slope
Function GetSlope(X1 As Variant, X2 As Variant, Y1 As Variant, Y2 As
Variant) As Double
GetSlope = (Y1 - Y2) / (X1 - X2)
End Function
Get Y Intercept
Function GetYIntercept(X1 As Variant, X2 As Variant, Y1 As Variant, Y2
As Variant) As Double
GetYIntercept = Y1 - (X1 * (Y1 - Y2) / (X1 - X2))
End Function
Inverse of an NxN matrix
Public Function GetInverse(M() As Double) As Double()
Dim RetVal() As Double: Dim Size As Integer
Dim Det As Double: Dim Adj() As Double
Dim i As Integer: Dim j As Integer
Size = UBound(M): Det = GetDet(M)
If Det <> 0 Then
ReDim RetVal(Size, Size)
Adj = GetAdjoint(M)
For i = 0 To Size
For j = 0 To Size
RetVal(i, j) = Adj(i, j) / Det
Next
Next
Erase Adj
GetInverse = RetVal
Erase RetVal
End If
End Function
Adjoint matrix - it is used to calculate the inverse of an NxN matrix
Public Function GetAdjoint(M() As Double) As Double()
Dim i As Integer: Dim j As Integer
Dim Size As Integer: Size = UBound(M)
Dim RetVal() As Double: ReDim RV(Size, Size)
For i = 0 To Size
For j = 0 To Size
RetVal(j, i) = ((-1) ^ (i + j)) * GetDet(GetMinor(M, i, j))
'RetVal(i, j)=matricea cofactor; RetVal(j, i)= transpusa matricii
cofactor
Next
Next
GetAdjoint = RetVal
Erase RetVal
End Function
Numberator
Function Numberator(InputInt As Integer) As String
If InputInt < 0 Then
Numberator = ""
ElseIf InputInt > -1 And InputInt < 10 Then
Numberator = "00" & CStr(InputInt)
ElseIf InputInt > 9 And InputInt < 100 Then
Numberator = "0" & CStr(InputInt)
ElseIf InputInt > 99 And InputInt < 1000 Then
Numberator = CStr(InputInt)
Else
MsgBox "Numbers are too big. Select less lines or start with a
lower value.", vbCritical, "Numbers are too large."
Numberator = ""
End If
End Function
Plane Equation
Public Function PlaneEquation(PartOrigin As iPct, PlaneOrigin As iPct,
FirstVector As iPct, SecondVector As iPct) As iPlan
Set PlaneEquation = New iPlan
PlaneEquation.Ax = PartOrigin.Y * (FirstVector.Z - SecondVector.Z) +
FirstVector.Y * (SecondVector.Z - PartOrigin.Z) + SecondVector.Y *
(PartOrigin.Z - FirstVector.Z)
PlaneEquation.By = PartOrigin.Z * (FirstVector.X - SecondVector.X) +
FirstVector.Z * (SecondVector.X - PartOrigin.X) + SecondVector.Z *
(PartOrigin.X - FirstVector.X)
PlaneEquation.Cz = PartOrigin.X * (FirstVector.Y - SecondVector.Y) +
FirstVector.X * (SecondVector.Y - PartOrigin.Y) + SecondVector.X *
(PartOrigin.Y - FirstVector.Y)
PlaneEquation.Dt = PlaneOrigin.X * (FirstVector.Y * SecondVector.Z -
SecondVector.Y * FirstVector.Z) + FirstVector.X * (SecondVector.Y *
PlaneOrigin.Z - PlaneOrigin.Y * _
SecondVector.Z) + SecondVector.X * (PlaneOrigin.Y * FirstVector.Z -
FirstVector.Y * PlaneOrigin.Z)
End Function
Points on the same side of the plane (2 points)
Public Function WhichSideOfPlane(Plane As iPlan, FirstPoint As iPct,
SecondPoint As iPct) As Integer()
Dim ArrReturn() As Integer: ReDim ArrReturn(1)
ArrReturn(0) = Plane.Ax * FirstPoint.X + Plane.By * FirstPoint.Y +
Plane.Cz * FirstPoint.Z - Plane.Dt
ArrReturn(1) = Plane.Ax * SecondPoint.X + Plane.By * SecondPoint.Y +
Plane.Cz * SecondPoint.Z - Plane.Dt
WhichSideOfPlane = ArrReturn
Erase ArrReturn
End Function
RGB to Hex
Public Function rgbtohex(r As Byte, g As Byte, b As Byte)
'input format = 255,255,255
'Get the r value
If r < 16 Then
hex1 = 0 & Hex(r)
Else
hex1 = Hex(r)
End If
'Get the g value
If r < 16 Then
hex2 = 0 & Hex(g)
Else
hex2 = Hex(g)
End If
'Get the b value
If b < 16 Then
hex3 = 0 & Hex(b)
Else
hex3 = Hex(b)
End If
rgbtohex = "#" & hex1 & hex2 & hex3
End Function
Subtract Date Time
Function SubtractDateTime(Time1, Time2)
Dim TimeDiff
SecDifference = Second(Time2) - Second(Time1)
MinDifference = Minute(Time2) - Minute(Time1)
HourDifference = Hour(Time2) - Hour(Time1)
DayDifference = Day(Time2) - Day(Time1)
If SecDifference < 0 Then
SecDifference = 60 + SecDifference
MinDifference = MinDifference - 1
End If
If MinDifference < 0 Then
MinDifference = 60 + MinDifference
HourDifference = HourDifference - 1
End If
If HourDifference < 0 Then
HourDifference = 24 + HourDifference
DayDifference = DayDifference - 1
End If
If DayDifference < 0 Then
DayDifference = 31 + DayDifference
End If
SubtractDateTime = SecDifference + MinDifference * 60 + HourDifference
* 3600 + DayDifference * 86400
End Function
Vector of line
Public Function GetLineVector(FirstPoint As iPct, SecondPoint As iPct)
As iPct
Dim Dist As Double: Set GetLineVector = New iPct
Dist = P2PDist(FirstPoint, Seconpoint)
GetLineVector.X = (SecondPoint.X - FirstPoint.X) / Dist
GetLineVector.Y = (SecondPoint.Y - FirstPoint.Y) / Dist
GetLineVector.Z = (SecondPoint.Z - FirstPoint.Z) / Dist
End Function