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

Article technique

Ce texte a été traduit par Google Translate Lire le texte source
RF-COM/RS-COM est une interface programmable qui permet d'élargir les possibilités des programmes principaux RFEM et RSTAB à l'aide de macros d'entrées personnalisées ou à l'aide de programmes de post-traitement. Cet article détaille la création d'un outil pour copier et déplacer des lignes directrices sélectionnées dans RFEM. Il est en outre possible de copier ou déplacer les lignes directrices dans un autre plan de travail. L'environnement de programmation utilisé ici 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 RFEM Type Library Dlubal

Tableau

Le vecteur de déplacement et le nombre de copies doivent être entrés dans le tableau d'entrée. Pour créer ce tableau, un userform (formulaire utilisateur) est généré en cliquant sur « Insérer » - « UserForm » dans l'éditeur VBA. Les commandes nécessaires doivent être placées sur ce formulaire : chacune doit être sélectionnée dans la boîte à outils et enregistrée sur ce formulaire. Les propriétés telles que la taille, la position ou encore le nom du formulaire peuvent être définies dans la fenêtre des propriétés.

Figure 02 - Tableau d'entrée

Seules des décimales peuvent être entré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 indiqué ci-dessous.

Option Explicit

'--------------------------------------------------------------------------
' Fermer la fenêtre en cliquant 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 en cliquant 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 retours 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 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 Sub

Déplacer et copier les lignes directrices

Le code source permettent de déplacer et copier les lignes directrices sélectionnées est détaillé ci-dessous. Chaque étape est expliquée par un commentaire.

Option Explicit

Enum Errors
Err_RFEM = 513 ' RFEM fermé 
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 la 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
' Les coordonnées des lignes directrices (X, Y, Z) de la copie seront ajustées selon 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
' Les coordonnées de la ligne directrice (X, Y, Z) seront ajustées selon 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

' Traitement des erreurs
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

Cet article contient des informations détaillées sur un outil pour le déplacement et la copie des lignes directrices dans RFEM. La même méthode permet la création d'un outil correspondant pour RSTAB. Cet outil est démarré via Excel. Il est également possible d'intégrer cet outil dans RFEM ou RSTAB, comme le décrit cet article.

Mots-Clés

COM API VBA Ligne directrice

Liens

Contactez-nous

Contactez-nous

Des questions sur nos produits ? Besoin de conseils sur un projet ?
Contactez notre assistance technique gratuite par e-mail, via le chat Dlubal ou sur notre forum international. N'hésitez pas à consulter les nombreuses solutions et astuces de notre FAQ.

+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
RSTAB Autres
RS-COM 8.xx

Module additionnel

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

Prix de la première licence
580,00 USD