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

Voir le sujet précédent Voir le sujet suivant Aller en bas

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

Message par Guss_ le Ven 8 Aoû 2014 - 3:23

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



Dernière édition par Guss_ le Ven 28 Aoû 2015 - 21:45, édité 1 fois

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par Guss_ le Mer 19 Nov 2014 - 21:45

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


Dernière édition par Guss_ le Jeu 20 Nov 2014 - 0:21, édité 1 fois

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par xorman le Mer 19 Nov 2014 - 23:03

super tes astuces...ca va me servir..merci
avatar
xorman
actif
actif

Messages : 98
Date d'inscription : 06/09/2008
Age : 41
Localisation : Cherbourg

http://www.myimpression3d.com

Revenir en haut Aller en bas

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

Message par Guss_ le Jeu 20 Nov 2014 - 0:22

De rien c'est fait pour ça Smile

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par Guss_ le Mar 25 Nov 2014 - 21:43

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

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par ramzar le Jeu 27 Nov 2014 - 1:29

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

ramzar
timide
timide

Messages : 10
Date d'inscription : 13/09/2014
Localisation : Canada

Revenir en haut Aller en bas

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

Message par xorman le Jeu 27 Nov 2014 - 2:00

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
   
avatar
xorman
actif
actif

Messages : 98
Date d'inscription : 06/09/2008
Age : 41
Localisation : Cherbourg

http://www.myimpression3d.com

Revenir en haut Aller en bas

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

Message par Guss_ le Jeu 27 Nov 2014 - 2:03

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" Wink

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par Guss_ le Ven 28 Aoû 2015 - 1:48

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

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par Guss_ le Ven 28 Aoû 2015 - 21:50

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

Guss_
Fédérateur
Fédérateur

Messages : 498
Date d'inscription : 08/01/2010

Revenir en haut Aller en bas

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

Message par Arafat le Lun 5 Sep 2016 - 10:39

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

Arafat
timide
timide

Messages : 13
Date d'inscription : 20/02/2015
Localisation : Bordeaux

Revenir en haut Aller en bas

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

Message par Contenu sponsorisé


Contenu sponsorisé


Revenir en haut Aller en bas

Voir le sujet précédent Voir le sujet suivant Revenir en haut

- Sujets similaires

 
Permission de ce forum:
Vous ne pouvez pas répondre aux sujets dans ce forum