Insertion de la référence
La bibliothèque d’objets RFEM doit tout d’abord être intégrée à l’éditeur VBA en cliquant sur « Outils »→ « Références ».
Fenêtre d’entrée
Le vecteur de déplacement, ainsi que le nombre de copies, doivent être entrés dans le tableau d’entrée. Pour créer le tableau d’entrée, un userform est généré en cliquant sur « Insérer »→ « UserForm » dans l’éditeur VBA. Les commandes nécessaires seront ensuite placées sur le Userform. Il suffit de sélectionner la commande souhaitée dans la boîte à outils et de l’enregistrer sur le userform. Les propriétés comme la taille, position, nom du Userform peuvent être définies dans la fenêtre de propriétés.
Lors de l’entrée de données, seuls des nombres décimaux sont autorisées pour le vecteur de déplacement et seuls des nombres entiers pour le nombre de copies. Le code source de la fenêtre d’entrée est affiché ci-dessous.
Option Explicit
'--------------------------------------------------------------------------
' Fermer la fenêtre lorsqu'on clique sur Annuler
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
frmGuideline.Hide
End Sub
'--------------------------------------------------------------------------
' Ouvrir la procédure pour déplacer/copier les lignes directrices et fermer la fenêtre lorsqu'on clique sur OK
'--------------------------------------------------------------------------
Private Sub cmdOK_Click()
If txbAnz.Value = "" Then
txbShow.Value = 0
End If
If txbX.Value = "" Then
txbX.Value = 0
End If
If txbY.Value = "" Then
txbY.Value = 0
End If
If txbZ.Value = "" Then
txbZ.Value = 0
End If
Call modGuideline.SetGuidelines(txbAnz.Value, txbX.Value, txbY.Value, txbZ.Value)
frmGuideline.Hide
End Sub
'--------------------------------------------------------------------------
' Fonctionnalité pour n'autoriser que les décimales
'--------------------------------------------------------------------------
Private Function TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Select Case iKeyCode
' Autoriser les signes suivants :
' 8 retour arrière pour corriger
' 48-57 nombres de 0 à 9
' 96-105 nombres de 0 à 9 (pavé numérique)
' 37, 39 touches de curseur ()
' 46 touche Suppr
Case 48 To 57, 8, 96 To 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' N'autoriser qu'un signe moins en première position
' 109 moins (pavé numérique)
' 189 moins
Case 109, 189:
If InStr(1, objTextBox, "-", vbTextCompare) > 0 Or objTextBox.SelStart <> 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' N'autoriser qu'une virgule ou un point et remplacer le point par la virgule
' 188 virgule
' 110 virgule (pavé numérique)
' 190 point
Case 190, 188, 110:
If InStr(1, objTextBox, ",", vbTextCompare) > 0 Or objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorer tous les autres signes
Case Else: TxT_KeyDown = 0
End Select
End Function
'--------------------------------------------------------------------------
' N'autoriser que les nombres décimaux pour entrer la coordonnée X
'--------------------------------------------------------------------------
Private Sub txbX_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' N'autoriser que les nombres décimaux pour entrer la coordonnée Y
'--------------------------------------------------------------------------
Private Sub txbY_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' N'autoriser que les nombres décimaux pour entrer la coordonnée Z
'--------------------------------------------------------------------------
Private Sub txbZ_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' N'autoriser que les nombres entiers pour entrer le nombre de copies
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Select Case iKeyCode
' N'autoriser que les nombres de 0 à 9
Case 48 To 57
' Ignorer tous les autres signes
Case Else: iKeyCode = 0
End Select
End SubDéplacer et copier les lignes directrices
Le code source permettant de déplacer et copier les lignes directrices sélectionnées est affiché ci-dessous. Chaque étape est expliquée dans les commentaires.
Option Explicit
Enum Errors
Err_RFEM = 513 ' RFEM non-ouvert
Err_Model = 514 ' Aucun modèle ouvert
Err_Guideline = 515 ' Aucune ligne directrice disponible
Err_Guideline_sel = 516 ' Aucune ligne directrice sélectionnée
End Enum
'--------------------------------------------------------------------------
' Procédure pour déplacer et copier les lignes directrices sélectionnées
'--------------------------------------------------------------------------
Sub SetGuidelines(iAnz As Integer, dNodeX, dNodeY, dNodeZ As Double)
Dim model As RFEM5.model
Dim app As RFEM5.Application
Dim guides As IGuideObjects
Dim lines() As Guideline
Dim iCountAll, iCountSel, i, iAnzKopie, iGuideNo As Integer
Dim newLayerLine As Guideline
On Error GoTo ErrorHandler
' Obtenir l'interface RFEM
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Signaler une erreur si RFEM n'est pas ouvert
Err.Raise Errors.Err_RFEM
End If
' Bloquer la licence COM et l'accès au programme
app.LockLicense
' Obtenir l'interface pour le modèle actif
If app.GetModelCount > 0 Then
Set model = app.GetActiveModel
Else
' Signaler une erreur si aucun modèle n'est ouvert
Err.Raise Errors.Err_Model
End If
' Obtenir l'interface pour les lignes directrices
Set guides = model.GetGuideObjects
' Définir le nombre de lignes directrices
model.GetModelData.EnableSelections (False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 Then
' Signaler une erreur si aucune ligne directrice n'est disponible
Err.Raise Errors.Err_Guideline
End If
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No
' Définir les numéros des lignes directrices sélectionnées
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount
If iCountSel > 0 Then
' Copier les lignes directrices sélectionnées
guides.PrepareModification
lines = guides.GetGuidelines()
If iShow > 0 Then
For iShowCopy = 1 To iShow
For i = 0 To iCountSel - 1
newLayerLine.WorkPlane = lines(i).WorkPlane
' Créer un nouveau plan de travail de la ligne directrice si la ligne directrice doit être copiée vers un autre plan de travail
If (lines(i).WorkPlane = PlaneXY And dNodeZ <> 0) Then
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ * iShowCopy
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
ElseIf (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Then
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX * iShowCopy
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
ElseIf (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Then
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y + dNodeY * iShowCopy
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
Else
' Lignes directrices dans le même plan de travail
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
End If
newLayerLine.Type = lines(i).Type
newLayerLine.Angle = lines(i).Angle
newLayerLine.Radius = lines(i).Radius
' Les coordonnées des lignes directrices (X, Y, Z) de la copie sont ajustées par le vecteur de déplacement
newLayerLine.Point1.X = lines(i).Point1.X + dNodeX * iShowCopy
newLayerLine.Point1.Y = lines(i).Point1.Y + dNodeY * iShowCopy
newLayerLine.Point1.Z = lines(i).Point1.Z + dNodeZ * iShowCopy
newLayerLine.Point2.X = lines(i).Point2.X + dNodeX * iShowCopy
newLayerLine.Point2.Y = lines(i).Point2.Y + dNodeY * iShowCopy
newLayerLine.Point2.Z = lines(i).Point2.Z + dNodeZ * iShowCopy
newLayerLine.No = iGuideNo + i + 1
newLayerLine.Description = "Copier la ligne directrice " + CStr(lines(i).No)
guides.SetGuideline newLayerLine
Next
iCountAll = iCountAll + iCountSel
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No
Next
' Déplacer les lignes directrices sélectionnées
Else
For i = 0 To iCountSel - 1
' Déplacer les lignes directrices vers un autre plan de travail
If (lines(i).WorkPlane = PlaneXY And dNodeZ <> 0) Then
lines(i).WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ
ElseIf (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Then
lines(i).WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX
ElseIf (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Then
lines(i).WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y + dNodeY
End If
' Ajustement des coordonnées des lignes directrices (X, Y, Z) par le vecteur de déplacement
lines(i).Point1.X = lines(i).Point1.X + dNodeX
lines(i).Point1.Y = lines(i).Point1.Y + dNodeY
lines(i).Point1.Z = lines(i).Point1.Z + dNodeZ
lines(i).Point2.X = lines(i).Point2.X + dNodeX
lines(i).Point2.Y = lines(i).Point2.Y + dNodeY
lines(i).Point2.Z = lines(i).Point2.Z + dNodeZ
Next
guides.SetGuidelines lines
End If
guides.FinishModification
Else
' Signaler une erreur si aucune ligne directrice n'est sélectionnée
Err.Raise Errors.Err_Guideline_sel
End If
' Gestion d'erreur
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case Errors.Err_RFEM
MsgBox ("RFEM non ouvert")
Exit Sub
Case Errors.Err_Model
MsgBox ("Aucun fichier ouvert !")
Case Errors.Err_Guideline
MsgBox ("Aucune ligne directrice dans le fichier " & model.GetName & " disponible !")
Case Errors.Err_Guideline_sel
MsgBox ("Aucune ligne directrice dans le fichier " & model.GetName & " sélectionnée !")
Case Else
MsgBox "Erreur n° : " & Err.Number & vbLf & Err.Description
End Select
End If
' Si la licence COM est débloquée, l'accès au programme est à nouveau possible
app.UnlockLicense
Set app = Nothing
Set model = Nothing
Set guides = Nothing
End Sub
'--------------------------------------------------------------------------
' Initialisation
'--------------------------------------------------------------------------
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub
'--------------------------------------------------------------------------
' Fonctionnalité pour contrôler si RFEM est ouvert
'--------------------------------------------------------------------------
Function RFEM_open() As Boolean
Dim objWMI, colPro As Object
Set objWMI = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")
Set colPro = objWMI.ExecQuery _
("Select * from Win32_Process Where Name = 'RFEM64.exe'")
If colPro.Count = 0 Then
RFEM_open = False
Else
RFEM_open = True
End If
End FunctionRésumé et perspectives
Dans cet article, nous avons développé un outil pour le déplacement/copie des lignes directrices dans RFEM. La même méthode permet la création d’un outil correspondant pour RSTAB. Le démarrage de l’outil se fait sur Excel. Il est également possible d’intégrer cet outil dans l’interface RFEM ou RSTAB comme le décrit cet article :