Astuces et autres routines basiques utiles pour la création de macros

Ici j'aimerais qu'on puisse regrouper les petites routines, qu'on peut rencontrer régulièrement qui sont souvent bien utiles.

• Je suis tombé sur une routine qui permet de désactivé le rafraichissement de catia lors de l'exécution d'une macro.
  De ce fait le traitement de la macro est accéléré.
  Je pense que c'est très utile pour ceux qui on des macros ayant de long temps de traitement
  
  

  Code:

  
Sub CATMain()
CATIA.RefreshDisplay = False
‘enter code here
CATIA.RefreshDisplay = True
End Sub


  source : http://www.scripting4v5.com/additional-articles/tips-to-make-your-catia-macros-run-faster/
  
  
• Une macro que j'ai créé permettant de cacher automatiquement les flèches de repère bleus dans les différente vues de mise en plan
  

  Code:

  Option Explicit
Sub CATMain()
    '---- Début du script de résolution de l'objet : Axe horizontal
    Dim drawingDocument1 As DrawingDocument
    Set drawingDocument1 = CATIA.ActiveDocument
    Dim drawingSheets1 As DrawingSheets
    Set drawingSheets1 = drawingDocument1.Sheets
    Dim selection1 As Selection
    Set selection1 = drawingDocument1.Selection
    Dim visPropertySet1 As VisPropertySet
    Set visPropertySet1 = selection1.VisProperties
    Dim drawingSheet1 As DrawingSheet
    Set drawingSheet1 = drawingSheets1.Item("Calque.1")
    Dim drawingViews1 As DrawingViews
    Set drawingViews1 = drawingSheet1.Views
    
    Set visPropertySet1 = visPropertySet1.Parent
    
    '---- Fin du script de résolution
    Dim drawingView1 As DrawingView
    Dim geometricElements1 As GeometricElements
    Dim repere As GeometricElement
    Dim axe_h As GeometricElement
    Dim axe_v As GeometricElement
    Dim point2D1 As GeometricElement
    Dim A As Integer
    selection1.Clear '----  libère toutes les séléctions
    For A = 3 To drawingViews1.Count '---- séléctionne tous les repères
        Set drawingView1 = drawingViews1.Item(A)
        Set geometricElements1 = drawingView1.GeometricElements
        Set repere = geometricElements1.Item("Repère")
        Set axe_h = repere.GetItem("Axe horizontal")
        Set axe_v = repere.GetItem("Axe vertical")
        Set point2D1 = repere.GetItem("Origine")
        selection1.Add axe_v
        selection1.Add axe_h
        selection1.Add point2D1
    Next
    visPropertySet1.SetShow 1 '---- cache tout ce qui à été séléctionné
    selection1.Clear '---- libère toutes les séléctions

End Sub

  
  
• Une fonction permettant de choisir un répertoire
  

  Code:

  Function Choix_Rep(Titre As String) As String
    Dim ObjShell As Object, ObjFolder As Object
    Set ObjShell = CreateObject("shell.Application")
    Set ObjFolder = ObjShell.BrowseForFolder(0, Titre, 0)
    If (Not ObjFolder Is Nothing) Then
        Choix_Rep = ObjFolder.Items.Item.Path
    End If
    Set ObjFolder = Nothing
    Set ObjShell = Nothing
End Function

  
  
  
• Des fonctions permettant de lire et écrire dans les fichiers .ini
  Utile pour enregistrer des paramètres liè a une macro
  

  Code:

  
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
    (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
    ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
    (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
    ByVal lpFileName As String) As Long
Private Function LitDansFichierIni(Section As String, Cle As String, Fichier As String, _
    Optional ValeurParDefaut As String = "") As String
    Dim strReturn As String
    strReturn = String(255, 0)
    GetPrivateProfileString Section, Cle, ValeurParDefaut, strReturn, Len(strReturn), Fichier
    LitDansFichierIni = Left(strReturn, InStr(strReturn, Chr(0)) - 1)
End Function

Private Function EcritDansFichierIni(Section As String, Cle As String, _
    Valeur As String, Fichier As String) As Long
    EcritDansFichierIni = WritePrivateProfileString(Section, Cle, Valeur, Fichier)
End Function

  
  
  
• Pour les utilisateurs de base de donnée comme smarteam, une fonction permettant de vérifier si smarteam est connecté ou non
  

  Code:

  Function test_smarteam() As Boolean
    Dim smarteam As StiEngine
    Set smarteam = CATIA.GetItem("CAIEngine")
    test_smarteam = smarteam.IsConnected()
End Function

  
  
  
• Une fonction permettant de démarrer Excel
  

  Code:

  
Public Excel As Object
Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long

Sub start_excel()
 lignes = 10
 colonnes = 3
    
    '---- initialisation excel
    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set Excel = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Excel.Visible = True
    
'---- position Excel en 1er plan
    BringWindowToTop (Excel.hwnd)
    
'---- création de la feuille excel
    Excel.Workbooks.Add
End Sub

  
  
  
• Récupérer les nom et chemin de la macro en cours d'utilisation
  

  Code:

  Option Explicit

Sub CATMain()
  
    MsgBox Info_Macro("chemin")
     MsgBox Info_Macro("nom")
      MsgBox Info_Macro()
End Sub


Function Info_Macro(Optional Genre As String) As String
    Dim APC As Object
    Dim ChrI, i, t
    Set APC = CreateObject("MSAPC.Apc")
    Info_Macro = APC.VBE.ActiveVBProject.FileName
    If Genre = "nom" Then
            For i = 1 To Len(Info_Macro)
            ChrI = Left(Right(Info_Macro, i), 1)
                If ChrI = "\" Then
                    Info_Macro = Right(Info_Macro, i - 1)
                    Exit For
                End If
            Next
    Else
        If Genre = "chemin" Then
            For i = 1 To Len(Info_Macro)
            ChrI = Left(Right(Info_Macro, i), 1)
                If ChrI = "\" Then
                    Info_Macro = Left(Info_Macro, Len(Info_Macro) - i + 1)
                    Exit For
                End If
            Next
        End If
    End If
End Function

  
  

Une petite macro qui permet de générer une série de spline en fonction d'un fichiers de point formaté

Code:


Option Explicit

Sub CATMain()
    '------------- initialisation document de travail ---------------
    Dim documents1 As Documents
    Set documents1 = CATIA.Documents     'documents
    Dim partDocument1 As PartDocument
    Set partDocument1 = documents1.Add("Part")    'documents.document(créé une part)
    '------------- fin initialisation document de travail ---------------
    
    '------------- initialisation objet de travail ---------------
    Dim part1 As Part
    Set part1 = partDocument1.Part         'documents.document.part
    Dim hybridBodies1 As HybridBodies
    Set hybridBodies1 = part1.HybridBodies   'Documents.Document.Part.HybridBodies
    Dim hybridBody1 As HybridBody
    Set hybridBody1 = hybridBodies1.Add()    'Documents.Document.Part.HybridBodies.HybridBody (créé un set géometrique)
    Dim hybridShapeFactory1 As HybridShapeFactory
    Set hybridShapeFactory1 = part1.HybridShapeFactory   'Documents.Document.Part.HybridBodies.HybridBody.HybridShapeFactory
    '------------- fin initialisation objet de travail ---------------
    
    '------------- variables des travail -------------
    Dim X#, Y#, Z#
    X# = 0
    Y# = 0
    Z# = 0
    Dim nb_ligne, max_point, tps1, tps2, tps3, last_point
    Dim nom_ligne(), nb_point()
    Dim coord_start(), coord_end()
    Dim coord1(), temp1()
    

    '------------- variables des travail -------------
    
    '-------------- Lecture fichier ---------------
        'initiatilsation
            Dim oFileSys As Object
    Set oFileSys = CATIA.FileSystem

    Dim oFSO As Object
    Dim oFl
    Dim oTxt
    Dim chaine_traitement, point, ligne
    
        
        'Instanciation du FSO
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFl = oFSO.GetFile("G:\N2EDM\DISCO\D7_Dossier_Interfaces_Et_Echanges\Phy_Vers_Meca\cordonnées_lignes.txt")
    Set oTxt = oFl.OpenAsTextStream(1)
        'fin initialisation
    nb_ligne = 0
   max_point = 0
    With oTxt
        While Not .AtEndOfStream
            chaine_traitement = .ReadLine
            
            If chaine_traitement = "SL" Then
                
                ReDim Preserve nom_ligne(nb_ligne), nb_point(nb_ligne)
                nom_ligne(nb_ligne) = .ReadLine
                ReDim Preserve coord_start(2, nb_ligne), coord_end(2, nb_ligne)
                nb_point(nb_ligne) = .ReadLine
                
                If max_point < nb_point(nb_ligne) Then
                    last_point = max_point
                    max_point = nb_point(nb_ligne)
                    temp1() = coord1()

                                    
                    ReDim coord1(2, max_point - 1, nb_ligne)
                    For tps1 = 0 To 2
                        For tps2 = 0 To last_point - 1
                            For tps3 = 0 To nb_ligne - 1
                                coord1(tps1, tps2, tps3) = temp1(tps1, tps2, tps3)

                            Next
                        Next
                    Next
                End If
                ReDim Preserve coord1(2, max_point - 1, nb_ligne)
                
                For point = 0 To nb_point(nb_ligne) - 1
                    chaine_traitement = .ReadLine
                    If Len(chaine_traitement) <> 52 Then
                        MsgBox "erreur de lecteur des coordonée de la ligne " & nom_ligne(nb_ligne) & " série de points " & point
                    Else
                        coord1(0, point, nb_ligne) = Mid(chaine_traitement, 1, 7)
                        coord1(1, point, nb_ligne) = Mid(chaine_traitement, 10, 7)
                        coord1(2, point, nb_ligne) = Mid(chaine_traitement, 19, 7)
                    End If
                    'MsgBox point
                Next
                nb_ligne = nb_ligne + 1
            End If
            
        Wend
    End With
    
    '------------- fin lecture fichier ---------------
    
    '------------- initialisation de la spline --------------------
    Dim hybridShapeSpline1 As HybridShapeSpline
    Dim reference2 As Reference
    '------------- fin initialisation de la spline --------------------
    
    '------------- initialisation point a créer ---------------
    Dim hybridShapePointCoord1 As HybridShapePointCoord
    '------------- fin initialisation point a créer ---------------
    
    '------------- initialisation du repere de référence---------------
    Dim axisSystems1 As AxisSystems
    Dim axisSystem1 As AxisSystem
    Dim reference1 As Reference
    '------------- fin initialisation du repere de référence ---------------
    
    
    For ligne = 0 To nb_ligne - 1
        
        '------------- création de la spline ------------------
        Set hybridShapeSpline1 = hybridShapeFactory1.AddNewSpline()  'Documents.Document.Part.HybridBodies.HybridBody.HybridShapeFactory.HybridShapeSpline (créé une spline)
        hybridShapeSpline1.SetSplineType 0
        hybridShapeSpline1.SetClosing 0
        '------------- fin création de la spline ------------------
        
        For point = 0 To nb_point(ligne) - 1
            
            '------------- création d un point ---------------
            X# = coord1(0, point, ligne)
            Y# = coord1(1, point, ligne)
            Z# = coord1(2, point, ligne)
            Set hybridShapePointCoord1 = hybridShapeFactory1.AddNewPointCoord(X#, Y#, Z#)    'Documents.Document.Part.HybridBodies.HybridBody.HybridShapeFactory.HybridShapePointCoord (créé un point)
            '------------- fin création d un point ---------------
            
            '------------- création du repere de référence---------------
            Set axisSystems1 = part1.AxisSystems  'documents.document.part.AxisSystems
            Set axisSystem1 = axisSystems1.Item("Repère absolu") 'documents.document.part.AxisSystems.AxisSystem
            Set reference1 = part1.CreateReferenceFromObject(axisSystem1) 'documents.document.part.Reference
            '------------- fin création du repere de référence ---------------
            
            ' ------------------ création point 1 ----------------
            hybridShapePointCoord1.RefAxisSystem = reference1
            hybridShapePointCoord1.Name = "Pt." & X# & "." & Y#
            hybridBody1.AppendHybridShape hybridShapePointCoord1
            part1.InWorkObject = hybridShapePointCoord1
            ' ------------------ fin création point 1 ----------------
        
            '------------- ajout de point sur la spline ------------------
            Set reference2 = part1.CreateReferenceFromObject(hybridShapePointCoord1) 'documents.document.part.Reference
            hybridShapeSpline1.AddPointWithConstraintExplicit reference2, Nothing, -1#, 1, Nothing, 0#
            hybridShapeSpline1.Name = nom_ligne(ligne)
            '------------- fin ajout de point sur la spline ------------------
        
        Next
        
        hybridBody1.AppendHybridShape hybridShapeSpline1
        part1.InWorkObject = hybridShapeSpline1
        part1.Update
    Next
End Sub


fichier contenant les points

Code:


SL
Ligne 0000 toto
00004
 00.000   00.000   00.000
 01.000   01.000   00.000
 02.000   04.000   00.000
 03.000   02.000   00.000

SL
Ligne 0002
00004
 00.000   01.000   00.000
 01.500   03.000   00.000
 03.000   07.000   00.000
 05.000   04.000   00.000

SL
Ligne 0003
00003
 00.000   01.000   00.000
 01.500   03.000   00.000
 03.000   07.000   00.000

SL
Ligne 0004
00005
 00.000   01.000   00.000
-01.500   03.000   00.000
 03.000  -07.000   00.000
 01.500   03.000   00.000
 03.000   07.000   00.000


"SL " defini le début de définition d'une ligne
la ligne suivante est une texte qui sera le nom de la spline
la ligne suivant est le nombre de points
les lignes suivantes sont les coordonnées x y z de chaque points

super tes astuces...ca va me servir..merci

De rien c'est fait pour ça

Une fonction permettant d'ouvrir une fenêtre de sélection de fichier

Code:

Function fichier(type_fichier As String)
    Dim strFilePath As String
    Dim objFile As File
    Dim objTextStream As TextStream
    Dim strLine As String
       'Display file open dialog
    strFilePath = CATIA.FileSelectionBox("Select Text File", type_fichier, 0)
    'If user clicked cancel (empty string is returned), then exit the program
    If strFilePath = "" Then Exit Function
     fichier = strFilePath

End Function

La fonction renvoie le chemin du fichier sélectionné, le paramétré permet de sélectionner le type de fichier par défaut

code de teste de la fonction

Code:


Sub catmain()
    Dim chemin
    chemin = fichier("*.txt")
    MsgBox chemin
End Sub

Lorsque que je veux être dans un module précis avant de commencer ma macro. Surtout pratique s'il y a changement de "workbench" dans la macro

Code:

'Vérification si je suis en part ou product
Dim woid As String 'workobjectid
woid = CATIA.GetWorkbenchId
If woid <> "Assembly" Then
MsgBox ("Mettre actif dans le product")
End
End If

Test pour savoir si le document actif est un CATProduct

Code:


Option Explicit

Public pub_current_document         As Document

Sub CATMain()

'---------------------------------------------
' Test que c'est un product qui est courant
'---------------------------------------------
On Error Resume Next
Set pub_current_document = CATIA.ActiveDocument
If Err.Number <> 0 Then
       MsgBox "Aucun document n'est chargé dans votre session CATIA V5 !", vbCritical, "Aucun traitement ne peut être effectué"
       Exit Sub
   End If
   
   If TypeName(pub_current_document) <> "ProductDocument" Then
       MsgBox "Le document courant n'est pas un CATProduct (ensemble) !", vbCritical, "Aucun traitement ne peut être effectué"
       Exit Sub
   End If

On Error GoTo 0

   Set pub_current_product = pub_current_document.Product

End Sub
   

ramzar a écrit:Lorsque que je veux être dans un module précis avant de commencer ma macro. Surtout pratique s'il y a changement de "workbench" dans la macro

Code:

'Vérification si je suis en part ou product
Dim woid As String 'workobjectid
woid = CATIA.GetWorkbenchId
If woid <> "Assembly" Then
MsgBox ("Mettre actif dans le product")
End
End If

Tu peux agrémenter d'un

Code:

CATIA.StartWorkbench ("Assembly")

à la place de MsgBox ("Mettre actif dans le product") pour basculer directement sur le mode "assembly design"

Salut à tous

Voici une Class qui permet de gérer facilement de paramètres qu'on pourrait vouloir garder en mémoire d'un lancement à l'autre d'une macro

Code:


'*********************************************************************
'* Classe : Configuration
'*
'* Fonctions :  Enregistre dans un fichier .ini des valeurs à sauvgarder
'* Modification : 27/08/15
'* Version : 0.1
'**********************************************************************

Option Explicit
Private Path As String 'variable contenant le chemin du fichier de configuration
Private App_name As String 'variable contenant le nom de la macro dont on veut garder des configuration
Private Version_App As String 'version de le macro si on veux s'y retrouver après plusieurs évolution

 
'---  fonctions permettant la gestion des fichiers .ini
'on utilise les fonctions 'GetPrivateProfileStringA' et 'WritePrivateProfileStringA' de la librairie 'kernel32'
Private Declare Function ini_Lecture Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal Nom_App As String, ByVal Clef As Any, ByVal Valeur_Default As String, ByVal Variable_retour As String, ByVal Longueur As Long, ByVal Chemin_ini As String) As Long

Private Declare Function ini_Ecriture Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal Nom_App As String, ByVal Clef As Any, ByVal Valeur As Any, ByVal Chemin_ini As String) As Long


Private Sub Class_initialize() 'initialisation de la class, génère le chemin de configuration par defaut
    Dim WshShell As Object, WshSysEnv As Object
    Set WshShell = CreateObject("WScript.Shell")
    Set WshSysEnv = WshShell.Environment("PROCESS")
    Path = WshSysEnv("appdata") + "\DassaultSystemes\CATSettings\Macros_Settings.ini"
    App_name = ""
    Version_App = ""
    ' le chemin par defaut est celui des cat settings de la session active
End Sub

' gestion de la propriété du chemin du fichier de configurations
Public Property Let Chemin(Path_Conf As String)
    Path = Path_Conf
End Property
Public Property Get Chemin() As String
    Chemin = Path
End Property

' gestion de la propriété du nom a associer à la macro
Public Property Let Nom(Nom_Macro As String)
    App_name = Nom_Macro
End Property
Public Property Get Nom() As String
    Nom = App_name
End Property

'gestion de la propriété de la version de la macro
Public Property Let Version(Version_Macro As String)
    Version_App = Version_Macro
End Property
Public Property Get Version() As String
    Version = Version_App
End Property

Public Sub Enregistre(Clef As String, Valeur As String) 'enregistre les données en fonction de la clef
    If App_name = "" Or Version_App = "" Then
        MsgBox "la propriété ' Nom ' n'est pas renseignée"
    Else
        If App_name = "" Or Version_App = "" Then
            MsgBox "la propriété ' Version ' n'est pas renseignée"
        Else
            ini_Ecriture App_name + " " + Version_App, Clef, Valeur, Path
        End If
    End If
End Sub

Public Function Lecture(Clef As String) 'lecture et mise en forme des données lue en fonction de la clef
    Dim Valeur_Retour As String
    Dim ValeurParDefaut
        If App_name = "" Or Version_App = "" Then
          MsgBox "la propriété ' Nom ' n'est pas renseignée"
        Else
            If App_name = "" Or Version_App = "" Then
                MsgBox "la propriété ' Version ' n'est pas renseignée"
            Else
                ValeurParDefaut = ""
                Valeur_Retour = String(255, 0)
                ini_Lecture App_name + " " + Version_App, Clef, ValeurParDefaut, Valeur_Retour, Len(Valeur_Retour), Path
                Lecture = Left(Valeur_Retour, InStr(Valeur_Retour, Chr(0)) - 1)
            End If
    End If
End Function


Exemple d'utilisation

Code:

Option Explicit

Sub cat_main()
Dim Configuration As New Configuration
Dim mavaleur As String
Configuration.Nom = "test"
Configuration.Version = "0.1"

Configuration.Enregistre "val_test1", "truc"

mavaleur = Configuration.Lecture("val_test1")

MsgBox mavaleur + vbCrLf + Configuration.Chemin + vbCrLf + Configuration.Nom + vbCrLf + Configuration.Version

End Sub

Une fonction qui permet de scanner un répertoire et de renvoyer un tableau contenant la liste des fichiers du répertoire scanner.
On peut ajouter optionnellement un paramètre de filtrage, le chaîne de caractère est rechercher dans le nom de chaque fichier et listé.
Si aucun fichier n'est trouvé alors Scan_Rep() = "Pas de Fichier trouvé"

Code:

Function Scan_Rep(Chemin As String, Optional Type_Fichier As String = "") As String()
    Dim FSO As Object, Reprtoire As Object, Liste() As String, Fichier, Compteur
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Compteur = -1
    Set Reprtoire = FSO.GetFolder(Chemin)
    For Each Fichier In Reprtoire.Files
        If (InStr(1, Fichier.Name, Type_Fichier, 1) > 0) Then
            Compteur = Compteur + 1
            ReDim Preserve Liste(Compteur)
            Liste(Compteur) = Fichier.Name
        End If
    Next
    If Compteur = -1 Then
        ReDim Liste(0)
        Liste(0) = "Pas de Fichier trouvé"
    End If
    Scan_Rep = Liste()
End Function

Un exemple

Code:

Option Explicit

Sub CatMain()
Dim List() As String, N
List = Scan_Rep(Choix_Rep("Choissiez un repertoire"))

        For N = LBound(List) To UBound(List)
          Debug.Print List(N)
        Next N

End Sub

Bonjour,

Un lot complet de fonctions mathématiques pour les macros de construction géométrique.
Récupéré du site http://www.grozeaion.com/catia/v5-programming/112-useful-catia-vba-functions

Code:

1. Create a Module in your project and paste the code below

Public Type iPct
 X As Double
 Y As Double
 Z As Double
End Type
Public Type iPlan
 Ax As Double
 By As Double
 Cz As Double
 Dt As Double
End Type
Public Enum iIntVal
 Intersectie = 0    'Intersection
 Paralele = 1
 Oblice = 2    'Skew
End Enum
Public Type iIntersect
 Result As iIntVal
 Val As iPct
End Type
Sub CATMain()
 Dim Q As New clsGVI
 Dim A As iPct
 Dim B As iPct
 Dim C As iPct
 Dim D As iPct
 'intersectie
 A.X = 1: A.Y = 1: A.Z = 1
 B.X = 3: B.Y = 3: B.Z = 1
 C.X = 0: C.Y = 1: C.Z = 4
 D.X = 0: D.Y = 3: D.Z = 3
 Dim X1 As Double
 X1 =Q.LLDistance(A, B, C, D)
'Unfold.Show
End Sub

2. Create a Class Module in the same project and rename it to clsGVI and paste the code below

Const PI As Double = 3.14159265358979

How to get point coordinates

Code:

Public Function GetPointXYZ(MyPoint As Variant) As iPct
Dim Coord(2): Set GetPointXYZ = New iPct
MyPoint.GetCoordinates Coord
GetPointXYZ.X = Coord(0): GetPointXYZ.Y = Coord(1): GetPointXYZ.Z = Coord(2)
Erase Coord
End Function


How to get point coordinates relative to an specified axis system

Code:


Public Function LCS(AxisSys As Variant, Point2Measure As iPct) As iPct
Dim AOrig(2): Dim Vx(2): Dim Vy(2): Dim Vz(2)
Dim iOrig As iPct: Dim iVx As iPct: Dim iVy As iPct: Dim iVz As iPct: Dim Diff As iPct
Set LCS = New iPct
AxisSys.GetOrigin AOrig: iOrig.X = AOrig(0): iOrig.Y = AOrig(1): iOrig.Z = AOrig(2)
AxisSys.GetXAxis Vx: iVx.X = Vx(0): iVx.Y = Vx(1): iVx.Z = Vx(2)
AxisSys.GetYAxis Vy: iVy.X = Vy(0): iVy.Y = Vy(1): iVy.Z = Vy(2)
AxisSys.GetZAxis Vz: iVz.X = Vz(0): iVz.Y = Vz(1): iVz.Z = Vz(2)
NormalizeVector iVx, iVx
NormalizeVector iVy, iVy
NormalizeVector iVz, iVz
Diff.X = Point2Measure.X - iOrig.X: Diff.Y = Point2Measure.Y - iOrig.Y: Diff.Z = Point2Measure.Z - iOrig.Z
LCS.X = DotProduct(Diff, iVx): LCS.Y = DotProduct(Diff, iVy): LCS.Z = DotProduct(Diff, iVz)
Set iOrig = Nothing: Set iVx = Nothing: Set iVy = Nothing: Set iVz = Nothing: Set Diff = Nothing
Erase AOrig: Erase Vx: Erase Vy: Erase Vz
End Function

How to Normalize of a vector

Code:

Public Sub NormalizeVector(IVect As iPct, ByRef NVect As iPct)
Dim Mag As Double
Mag = Sqr(IVect.X ^ 2 + IVect.Y ^ 2 + IVect.Z ^ 2)
If Mag < 0.0000001 Then Call Err.Raise(1001, , "Zero length vector cannot be normalized")
NVect.X = IVect.X / Mag
NVect.Y = IVect.Y / Mag
NVect.Z = IVect.Z / Mag
End Sub


How to get Plane Equation

Code:

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

How to get plane vectors

Code:


Public Function GetPlaneVectors(MyPlane As Variant) As iPct()
Dim ArrRet() As iPct: ReDim ArrRet(1)
Dim V1(2): Dim V2(2)
MyPlane.GetFirstAxis V1: ArrRet(0).X = V1(0): ArrRet(0).Y = V1(1): ArrRet(0).Z = V1(2)
MyPlane.GetSecondAxis V2: ArrRet(1).X = V2(0): ArrRet(1).Y = V2(1): ArrRet(1).Z = V2(2)
GetPlaneVectors = ArrRet
Erase ArrRet: Erase V1: Erase V2
End Function


How to get angle between two planes - Dihedral Angle

Code:

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

Arccos function

Code:

Public Function ArcCos(Radians As Double) As Double
If Round(Radians,  = 1 Then ArcCos = 0: Exit Function
If Round(Radians,  = -1 Then ArcCos = PI: Exit Function
ArcCos = Atn(-Radians / Sqr(1 - Radians ^ 2)) + 2 * Atn(1)
End Function


Arcsin function

Code:

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

How to get distance between two points

Code:

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


Are two points on the same side of the plane?

Code:

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

How to get the vector of line

Code:

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

How to Get BrepName from Catia Selection

Code:


Public Function GetBrep(MyBRepName As String) As String
MyBRepName = Replace(MyBRepName, "Selection_", "")
MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
'");WithTemporaryBody;WithoutBuildError;WithInitialFeatureSupport;MonoFond;MFBRepVersion _CXR14)"
GetBrep = MyBRepName
End Function


How to determine if two lines are skew, intersecting or parallel

Code:

Public Function LLIntersect(A As iPct, B As iPct, C As iPct, D As iPct) As iIntersect
Dim M(3, 3) As Double
M(0, 0) = A.X: M(0, 1) = A.Y: M(0, 2) = A.Z: M(0, 3) = 1
M(1, 0) = B.X: M(1, 1) = B.Y: M(1, 2) = B.Z: M(1, 3) = 1
M(2, 0) = C.X: M(2, 1) = C.Y: M(2, 2) = C.Z: M(2, 3) = 1
M(3, 0) = D.X: M(3, 1) = D.Y: M(3, 2) = D.Z: M(3, 3) = 1
If GetDet(M) <> 0 Then Erase M: LLIntersect.Result = Oblice: Exit Function    'skew lines
Dim CxB() As Double: Dim AxB() As Double: ReDim CxB(2): ReDim AxB(2)
Dim Av(2) As Double: Dim Bv(2) As Double: Dim Cv(2) As Double
Av(0) = B.X - A.X: Av(1) = B.Y - A.Y: Av(2) = B.Z - A.Z
Bv(0) = D.X - C.X: Bv(1) = D.Y - C.Y: Bv(2) = D.Z - C.Z
Cv(0) = C.X - A.X: Cv(1) = C.Y - A.Y: Cv(2) = C.Z - A.Z
CxB = CrossProd(Cv, Bv): AxB = CrossProd(Av, Bv)
Dim s As Double
On Error GoTo paralelele
s = DotProd(CxB, AxB) / Abs(DotProd(AxB, AxB))
Dim iInter As iPct
iInter.X = A.X + Av(0) * s    'X coordinate of intersection
iInter.Y = A.Y + Av(1) * s    'Y coordinate of intersection
iInter.Z = A.Z + Av(2) * s    'Z coordinate of intersection
LLIntersect.Result = Intersectie    'intersecting lines
LLIntersect.Val = iInter
paralelele:
Erase CxB: Erase AxB: Erase Cv: Erase Bv: Erase Av
If Err.Number <> 0 Then LLIntersect.Result = PParalele: Err.Clear    'parallel lines
End Function

How to get the distance between two skew lines

Code:

Public Function SkewLDist(A As iPct, B As iPct, C As iPct, D As iPct) As Double
Dim Av(2) As Double: Dim Bv(2) As Double: Dim Cv(2) As Double
Dim Det(2, 2) As Double
Av(0) = A.X - B.X: Av(1) = A.Y - B.Y: Av(2) = A.Z - B.Z
Bv(0) = C.X - A.X: Bv(1) = C.Y - A.Y: Bv(2) = C.Z - A.Z
Cv(0) = D.X - C.X: Cv(1) = D.Y - C.Y: Cv(2) = D.Z - C.Z
Det(0, 0) = DotProd(Cv, Cv): Det(0, 1) = DotProd(Cv, Av): Det(0, 2) = DotProd(Cv, Bv)
Det(1, 0) = DotProd(Cv, Av): Det(1, 1) = DotProd(Av, Av): Det(1, 2) = DotProd(Av, Bv)
Det(2, 0) = DotProd(Cv, Bv): Det(2, 1) = DotProd(Av, Bv): Det(2, 2) = DotProd(Bv, Bv)
Dim v As Double
v = GetDet(Det)
SkewLDist = Sqr(v / (Det(0, 0) * Det(1, 1) - Det(1, 0) ^ 2))
End Function


How to get DOT product of two vectors - lenght must be 3

Code:

Public Function DotProd(V1() As Double, V2() As Double) As Double
DotProd = V1(0) * V2(0) + V1(1) * V2(1) + V1(2) * V2(2)
End Function

How to get CROSS product of two vectors - lenght must be 3

Code:

Public Function CrossProd(V1() As Double, V2() As Double) As Double()
Dim Res() As Double
ReDim Res(2)
Res(0) = V1(1) * V2(2) - V1(2) * V2(1)
Res(1) = V1(2) * V2(0) - V1(0) * V2(2)
Res(2) = V1(0) * V2(1) - V1(1) * V2(0)
CrossProd = Res
Erase Res
End Function

How to get inverse of an NxN matrix

Code:

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

How to get Determinant of an NxN matrix

Code:

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

How to get Adjoint matrix - it is used to calculate the inverse of an NxN matrix

Code:


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


How to get Minor matrix - it is used to calculate the determinant of an NxN matrix

Code:

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

How to aproximate an curve using Cubic Bezier curves

Code:


Public Function BSpline3(CollectionOfiPcts As Collection, Increment As Double) As Collection
Dim i As Double: Dim t As Double
Dim A As iPlan: Dim B As iPlan: Dim C As iPlan: Dim Point2Add As iPct
Set BSpline3 = New Collection
For i = 1 To CollectionOfiPcts.Count - 3
Set A = New iPlan: Set B = New iPlan: Set C = New iPlan
A.Ax = (-CollectionOfiPcts(i).X + 3 * CollectionOfiPcts(i + 1).X - 3 * CollectionOfiPcts(i + 2).X + CollectionOfiPcts(i + 3).X) / 6
A.By = (3 * CollectionOfiPcts(i).X - 6 * CollectionOfiPcts(i + 1).X + 3 * CollectionOfiPcts(i + 2).X) / 6
A.Cz = (-3 * CollectionOfiPcts(i).X + 3 * CollectionOfiPcts(i + 2).X) / 6
A.Dt = (CollectionOfiPcts(i).X + 4 * CollectionOfiPcts(i + 1).X + CollectionOfiPcts(i + 2).X) / 6
B.Ax = (-CollectionOfiPcts(i).Y + 3 * CollectionOfiPcts(i + 1).Y - 3 * CollectionOfiPcts(i + 2).Y + CollectionOfiPcts(i + 3).Y) / 6
B.By = (3 * CollectionOfiPcts(i).Y - 6 * CollectionOfiPcts(i + 1).Y + 3 * CollectionOfiPcts(i + 2).Y) / 6
B.Cz = (-3 * CollectionOfiPcts(i).Y + 3 * CollectionOfiPcts(i + 2).Y) / 6
B.Dt = (CollectionOfiPcts(i).Y + 4 * CollectionOfiPcts(i + 1).Y + CollectionOfiPcts(i + 2).Y) / 6
C.Ax = (-CollectionOfiPcts(i).Z + 3 * CollectionOfiPcts(i + 1).Z - 3 * CollectionOfiPcts(i + 2).Z + CollectionOfiPcts(i + 3).Z) / 6
C.By = (3 * CollectionOfiPcts(i).Z - 6 * CollectionOfiPcts(i + 1).Z + 3 * CollectionOfiPcts(i + 2).Z) / 6
C.Cz = (-3 * CollectionOfiPcts(i).Z + 3 * CollectionOfiPcts(i + 2).Z) / 6
C.Dt = (CollectionOfiPcts(i).Z + 4 * CollectionOfiPcts(i + 1).Z + CollectionOfiPcts(i + 2).Z) / 6
For t = 0 To 1 Step Increment
Set Point2Add = New iPct
Point2Add.X = A.Dt + A.Cz * t + A.By * t ^ 2 + A.Ax * t ^ 3
Point2Add.Y = B.Dt + B.Cz * t + B.By * t ^ 2 + B.Ax * t ^ 3
Point2Add.Z = C.Dt + C.Cz * t + C.By * t ^ 2 + C.Ax * t ^ 3
BSpline3.Add Point2Add
Set Point2Add = Nothing
Next
Set A = Nothing: Set B = Nothing: Set C = Nothing
Next
End Function

How to aproximate an curve using Quadratic Bezier curves

Code:


Public Function BSplineC(CollectionOfiPcts As Collection, Increment As Double) As Collection
Dim j As Double
Dim t As Double
Dim A As iPct: Dim B As iPct: Dim C As iPct: Dim Point2Add As iPct
Set BSplineC = New Collection
For j = 2 To CollectionOfiPcts.Count - 1
Set A = New iPct: Set B = New iPct: Set C = New iPct
A.X = (CollectionOfiPcts(j - 1).X - 2 * CollectionOfiPcts(j).X + CollectionOfiPcts(j + 1).X) / 2
A.Y = (-2 * CollectionOfiPcts(j - 1).X + 2 * CollectionOfiPcts(j).X) / 2
A.Z = (CollectionOfiPcts(j - 1).X + CollectionOfiPcts(j).X) / 2
B.X = (CollectionOfiPcts(j - 1).Y - 2 * CollectionOfiPcts(j).Y + CollectionOfiPcts(j + 1).Y) / 2
B.Y = (-2 * CollectionOfiPcts(j - 1).Y + 2 * CollectionOfiPcts(j).Y) / 2
B.Z = (CollectionOfiPcts(j - 1).Y + CollectionOfiPcts(j).Y) / 2
C.X = (CollectionOfiPcts(j - 1).Z - 2 * CollectionOfiPcts(j).Z + CollectionOfiPcts(j + 1).Z) / 2
C.Y = (-2 * CollectionOfiPcts(j - 1).Z + 2 * CollectionOfiPcts(j).Z) / 2
C.Z = (CollectionOfiPcts(j - 1).Z + CollectionOfiPcts(j).Z) / 2
For t = 0 To 1 Step Increment
Set Point2Add = New iPct
Point2Add.X = A.Z + A.Y * t + A.X * t ^ 2
Point2Add.Y = B.Z + B.Y * t + B.X * t ^ 2
Point2Add.Z = C.Z + C.Y * t + C.X * t ^ 2
BSplineC.Add Point2Add
Set Point2Add = Nothing
Next
Set A = Nothing: Set B = Nothing: Set C = Nothing
Next
End Function

How to sort verctors

Code:

Public Sub SortVector(Array2Sort, Order As String)
Dim X As Integer
Dim Temp
Select Case Order
Case "A"
Sorted = False
Do While Not Sorted
Sorted = True
For X = 0 To UBound(Array2Sort) - 1
If Array2Sort(X) > Array2Sort(X + 1) Then
Temp = Array2Sort(X + 1)
Array2Sort(X + 1) = Array2Sort(X)
Array2Sort(X) = Temp
Sorted = False
End If
Next X
Loop
Case "D"
Sorted = False
Do While Not Sorted
Sorted = True
For X = 0 To UBound(Array2Sort) - 1
If Array2Sort(X) < Array2Sort(X + 1) Then
Temp = Array2Sort(X + 1)
Array2Sort(X + 1) = Array2Sort(X)
Array2Sort(X) = Temp
Sorted = False
End If
Next X
Loop
Case Else
MsgBox "Invalid parameter Value Order=A or D"
End Select
End Sub