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

Option Explicit

'--------------------------------------------------------------------------
' Fermer la fenêtre lorsqu'on clique sur Annuler
'--------------------------------------------------------------------------
Privé sous cmdClôture_Clic ()
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
'--------------------------------------------------------------------------
Sous externe cmdOK_Clic ()
Si txbNum.Value = « Alors
txbNumber.Value = 0
End If
Si txbX.Value = "" Alors
txbX.Valeur = 0
End If
Si txbY.Value = « Alors
txbY.Valeur = 0
End If
Si txbZ.Value = « Alors
txbZ.Valeur = 0
End If
Appeler modGuideline.SetGuidelines(txbAnz.Value, txbX.Value, txbY.Value, txbZ.Value)
frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Fonctionnalité pour n'autoriser que les décimales
'--------------------------------------------------------------------------
Fonction individuelle TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Sélectionner le cas 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
Cas 48 à 57, 8, 96 à 105, 37, 39, 46 : TxT_KeyDown = iKeyCode
' N'autoriser qu'un signe moins en première position
' 109 moins (pavé numérique)
' 189 moins
Cas 109, 189:
Si InStr(1, objTextBox, « - », vbTextComparer) > 0 Ou objetjTextBox.SelStart <> 0 Puis
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
Cas 190, 188, 110 :
Si InStr(1, objTextBox, '', vbTextComparer) > 0 Ou objetjTextBox.SelStart = 0 Puis
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorer tous les autres signes
Cas autre : TxT_KeyDown = 0
End Select
End Function

'--------------------------------------------------------------------------
' N'autoriser que les décimales pour entrer la coordonnée X
'--------------------------------------------------------------------------
Privé Sous txbX_KeyDown (ByVal iKeycode comme MSForms.RetourInteger, ByVal Shift comme nombre entier)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' N'autoriser que les décimales pour entrer la coordonnée Y
'--------------------------------------------------------------------------
Privé Sous txbY_KeyDown (ByVal iKeycode comme MSForms.RetourInteger, ByVal Shift comme nombre entier)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' N'autoriser que les décimales pour entrer la coordonnée Z
'--------------------------------------------------------------------------
Privé Sous txbZ_KeyDown (ByVal iKeycode comme MSForms.RetourInteger, ByVal Shift comme nombre entier)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' N'autoriser que les nombres entiers pour entrer le nombre de copies
'--------------------------------------------------------------------------
Privé Sous txbAnz_KeyPress(ByVal iKeyCode As MSForms.RetourInteger)
Sélectionner le cas iKeyCode
' N'autoriser que les nombres de 0 à 9
Cas 48 à 57
' Ignorer tous les autres signes
Cas autre : iKeyCode = 0
End Select
End Sub

Option Explicit

Erreurs d'énumération
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
'--------------------------------------------------------------------------
Sous-ensemble de lignes directrices (iNo. As Integer, dNodeX, dNodeY, dNodeZ As Double)
Dim model As RFEM5.model
Application Dim As RFEM5.Application
Dim repères comme IGuideObjects
Lignes Dim () Comme ligne directrice
Dim iCountAll, iCountSel, i, iAnzCopy, iGuideNo Comme nombre entier
Dim nouvelleCoucheLigne comme ligne directrice

Sur l'erreur accéder au gestionnaire d'erreurs

' 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 le licence COM et l'accès au programme
app.LockLicense

' Atteindre l'interface pour le modèle actif
Si app.GetModelCount > 0 Puis
Définir le modèle = app.GetActiveModel
Else
' Signaler une erreur si aucun modèle n'est ouvert
Err.Déclencher des erreurs.Err_Modèle
End If

' Atteindre l'interface pour les lignes directrices
Définir les repères = model.GetGuideObjects

' Définir les numéros des lignes directrices
model.GetModelData.EnableSelections (False)
iCount Tout = model.GetGuideObjects.GetGuidelineCount
Si iCountAll = 0, alors
' Signaler une erreur si aucune ligne directrice n'est disponible
Err.Raise-Errr.Err_Guideline
End If
iGuideNo = repères.GetGuideline(iCountAll - 1, AtIndicex).GetData.No

' Définir les numéros des lignes directrices sélectionnées
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount

Si iCountSel > 0, alors
' Copier les lignes directrices sélectionnées
repères.PrepareModification
lignes = repères.GetGuidelines ()
Si iNumber > 0 Alors
Pour iNo.Copier = 1 To iNo
Pour i = 0 To iCountSel - 1
newLayerLine.WorkPlane = line(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
Si (lines(i).WorkPlane = PlaneXY And dNodeZ <> 0) Then
newLayerLine.WorkPlaneOrigin.Z = line(i).WorkPlaneOrigin.Z + dNodeZ * iAnzKpie
newLayerLine.WorkPlaneOrigin.X = lignes (i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lignes (i).WorkPlaneOrigin.Y
ElseSi (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Then
newLayerLine.WorkPlaneOrigin.X = line(i).WorkPlaneOrigin.X + dNodeX * iAnzKpie
newLayerLine.WorkPlaneOrigin.Y = lignes (i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lignes (i).WorkPlaneOrigin.Z
ElseSi (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Puis
newLayerLine.WorkPlaneOrigin.Y = line(i).WorkPlaneOrigin.Y + dNodeY * iAnzKpie
newLayerLine.WorkPlaneOrigin.X = lignes (i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Z = lignes (i).WorkPlaneOrigin.Z
Else
' Lignes directrices dans le même plan de travail
newLayerLine.WorkPlaneOrigin.X = lignes (i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lignes (i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lignes (i).WorkPlaneOrigin.Z
End If
newLayerLine.Type = lignes(i).Type
newLayerLine.Angle = line(i).Angle
newLayerLine.Rayus = lignes(i).Rayus
'Les coordonnées des lignes directrices (X, Y, Z) de la copie sont ajustées par le vecteur de déplacement
newLayerLine.Point1.X = line(i).Point1.X + dNodeX * iAnzKpie
newLayerLine.Point1.Y = line(i).Point1.Y + dNodeY * iAnzKpie
newLayerLine.Point1.Z = line(i).Point1.Z + dNodeZ * iAnzKpie
newLayerLine.Point2.X = line(i).Point2.X + dNodeX * iAnzKpie
newLayerLine.Point2.Y = line(i).Point2.Y + dNodeY * iAnzKpie
newLayerLine.Point2.Z = line(i).Point2.Z + dNodeZ * iAnzKpie
newLayerLine.No = iGuideNo + i + 1
newLayerLine.Description = « Copier la ligne directrice » + CStr(lines(i).No)
repères.SetGuideline newLayerLine
Suivant
iCount Tout = iCount Tout + iCountSel
iGuideNo = repères.GetGuideline(iCountAll - 1, AtIndicex).GetData.No
Suivant
' Déplacer les lignes directrices sélectionnées
Else
Pour i = 0 To iCountSel - 1
' Déplacer les lignes directrices vers un autre plan de travail
Si (lines(i).WorkPlane = PlaneXY And dNodeZ <> 0) Then
lignes(i).WorkPlaneOrigin.Z = lignes(i).WorkPlaneOrigin.Z + dNodeZ
ElseSi (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Then
lignes (i).WorkPlaneOrigin.X = lignes (i).WorkPlaneOrigin.X + dNodeX
ElseSi (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Puis
lignes (i).WorkPlaneOrigin.Y = lignes (i).WorkPlaneOrigin.Y + dNodeY
End If
' Ajustement des coordonnées des lignes directrices (X, Y, Z) par le vecteur de déplacement
line(i).Point1.X = lignes(i).Point1.X + dNodeX
line(i).Point1.Y = lignes(i).Point1.Y + dNodeY
line(i).Point1.Z = lignes(i).Point1.Z + dNodeZ
line(i).Point2.X = lignes(i).Point2.X + dNodeX
line(i).Point2.Y = lignes(i).Point2.Y + dNodeY
line(i).Point2.Z = lignes(i).Point2.Z + dNodeZ
Suivant
repères.SetGuidelineslines
End If
repères.FinishModification
Else
' Signaler une erreur si aucune ligne directrice n'est sélectionnée
Err.Déclencher des erreurs.Err_Guideline_sel
End If

' Gestion d'erreur
Gestionnaire d'erreur :
If Err.Number <> 0 Then
Sélectionner le cas d'erreur.numéro
Erreurs de cas.Err_RFEM
MsgBox ("RFEM is not opened")
Exit Sub
Erreurs de cas.Err_Modèle
MsgBox ("No file opened!")
Erreurs de cas.Err_Guideline
MsgBox ("No guidelines available in file " & model.GetName & " !")
Erreurs de cas.Err_Guideline_sel
MsgBox ("No guidelines selected in file " & model.GetName & " !")
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.DéverrouillerLicence

Définir l'application = Rien
Set model = Nothing
Définir les repères = Aucun

End Sub

'--------------------------------------------------------------------------
' Initialisation
'--------------------------------------------------------------------------
Sous initial ()
frmGuideline.txbX.Value = « 0 »
frmGuideline.txbY.Value = « 0 »
frmGuideline.xxbZ.Value = « 0 »
frmGuideline.txbAnz.Value = « 0 »
End Sub

'--------------------------------------------------------------------------
' Fonctionnalité pour contrôler si RFEM est ouvert
'--------------------------------------------------------------------------
Fonction RFEM_open () comme booléenne
Dim objet, colPro Comme objet

Set objWMI = GetObject(« winmgmts: » _
& "{imselfationLevel=imselfate}!\\" & "." & "\racine\cimv2")
Définir colPro = objWMI.Exec query_
(« Sélectionner * à partir de Win32_Process où Nom = 'RFEM64.exe' »)
Si colPro.Count = 0 Alors
RFEM_open = True
Else
RFEM_open = True
End If
End Function