Interface COM en VBA | 5. Création d'un outil pour copier et déplacer des lignes directrices

Article technique

RF-COM/RS-COM est une interface programmable qui permet à l'utilisateur d'élargir les possibilités des programmes principaux RFEM et RSTAB à l'aide de macros d'entrées personnalisés ou à l'aide de programmes de post-traitement. Dans cet article, nous allons développer un outil pour copier et déplacer des lignes directrices sélectionnées dans RFEM. Il est possible de copier ou déplacer les lignes directrices dans un autre plan de travail. Notre environnement de programmation est VBA dans Excel.

Insertion du lien

La bibliothèque d'objets RFEM doit tout d'abord être intégrée à l'éditeur VBA en cliquant sur "Outils" → "Références".

Figure 01 - Intégrer la Dlubal RFEM Type Library

Tableau

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 sont à disposer sur le userform. Il suffit de sélectionner la commande souhaitée dans la boîte à outils et enregistrée sur le userform. Les propriétés comme la taille, position, nom du userform peuvent être définis dans la fenêtre de propriétés.

Figure 02 - Tableau d'entrée

Lors de l'entrée de données seules des décimales sont autorisées pour le vecteur de déplacement et seuls des nombres entiers pour le nombre de copies. Le code source du tableau d'entrée est listé ci-dessous.

Option Explicite

'--------------------------------------------------------------------------
' 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
txbAnz.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 Touche 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 décimales 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 décimales 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 décimales 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 entier pour entrer le nombre de copies
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Select Case iKeyCode
' N'autoriser que les nombres 0 à 9
Case 48 To 57
' Ignorer tous les autres signes
Case Else: iKeyCode = 0
End Select
End Sub

Moving and Copying Guidelines

The source code to move and copy the selected guidelines is listed below. The single steps are explained in the comments.

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

' Atteindre RFEM
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Signaler une erreur si RFEM ne s'ouvre pas
Err.Raise Errors.Err_RFEM
End If

' Bloquer le licence COM et l'accès au programme
app.LockLicense

' Atteindre 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

' Atteindre l'interface pour les lignes directrices
Set guides = model.GetGuideObjects

' Définir les numéros des 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 iAnz > 0 Then
For iAnzKopie = 1 To iAnz
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 * iAnzKopie
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 * iAnzKopie
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 * iAnzKopie
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
' Coordonnées des lignes directrices (X, Y, Z) de la copie sera ajustée par le vecteur de déplacement
newLayerLine.Point1.X = lines(i).Point1.X + dNodeX * iAnzKopie
newLayerLine.Point1.Y = lines(i).Point1.Y + dNodeY * iAnzKopie
newLayerLine.Point1.Z = lines(i).Point1.Z + dNodeZ * iAnzKopie
newLayerLine.Point2.X = lines(i).Point2.X + dNodeX * iAnzKopie
newLayerLine.Point2.Y = lines(i).Point2.Y + dNodeY * iAnzKopie
newLayerLine.Point2.Z = lines(i).Point2.Z + dNodeZ * iAnzKopie
newLayerLine.No = iGuideNo + i + 1
newLayerLine.Description = "Kopie Hilfslinie " + 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
' Coordonnées de la ligne directrice (X, Y, Z) sera ajustée 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 is not opened")
Exit Sub
Case Errors.Err_Model
MsgBox ("No file opened!")
Case Errors.Err_Guideline
MsgBox ("No guidelines available in file " & model.GetName & " !")
Case Errors.Err_Guideline_sel
MsgBox ("No guidelines selected in file " & model.GetName & " !")
Case Else
MsgBox "Error-Nr. : " & 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 Function

Ré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 RFEM ou RSTAB, comme le décrit cet article.

Liens

Contactez-nous

Contactez-nous

Vous avez des questions relatives à nos produits ? Vous avez besoin de conseils pour votre projet en cours ? Contactez-nous ou visitez notre FAQ, vous y trouverez de nombreuses astuces et solutions.

+33 1 78 42 91 61

info@dlubal.fr

RFEM Logiciel principal
RFEM 5.xx

Programme de base

Logiciel de calcul de structures aux éléments finis (MEF) pour les structures 2D et 3D composées de plaques, voiles, coques, barres (poutres), solides et éléments d'assemblage

Prix de la première licence
3 540,00 USD
RSTAB Logiciel principal
RSTAB 8.xx

Programme de base

Logiciel de calcul de structures filaires composées de charpentes, poutres et treillis. Il permet d'effectuer le calcul linéaire et non-linéaire et de déterminer les efforts internes, déformations et réactions d'appui

Prix de la première licence
2 550,00 USD
RFEM Autres
RF-COM 5.xx

Module additionnel

Interface programmable (API) basée sur la technologie COM

Prix de la première licence
580,00 USD