COM rozhraní ve VBA | 5. Vytvoření nástroje na kopírování a posunování pomocných linií

Odborný článek

RF-COM/RS-COM je programovatelné rozhraní, díky kterému lze rozšířit programy RFEM a RSTAB o programy pro zadávání a postprocesory přizpůsobené uživatelům na míru. V tomto příspěvku je popsán vývoj nástroje pro kopírování a posunování vybraných pomocných linií v programu RFEM. Pomocné linie přitom lze kopírovat nebo posunovat také do jiných pracovních rovin. Jako softwarové prostředí se používá VBA v programu MS Excel.

Vložení odkazu

Nejdříve je nutno přes "Nástroje" → "Odkazy" vložit do VBA editoru knihovnu objektů z programu RFEM.

Obr. 01 - Vložit RFEM Type Library

Vstupní tabulka

Vstupní tabulka slouží k zadávání vektoru posunu a počtu kopií. Ve VBA editoru je kvůli vytvoření vstupní tabulky nutno založit formulář Userform pomocí "Vložit" -> "UserForm". Poté se potřebné řídící prvky umístí na formulář Userform. K tomu je zapotřebí vybrat příslušný řídící prvek ze seznamu nástrojů a poté ho uložit do formuláře Userform. Vlastnosti jako velikost, pozice, jméno formuláře Userform a řídící prvky se určují v okně vlastností.

Obr. 02 - Vstupní tabulka

Vektor posunu lze zadávat pouze ve formě desetinných čísel a počet kopií pouze ve formě celých čísel. Poté je uveden zdrojový text vstupní tabulky.

Option Explicit

'--------------------------------------------------------------------------
' Kliknutím na Zavřít se zavře okno.
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Přepnout na posunování/kopírování pomocných linií a zavřít okno kliknutím na 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

'--------------------------------------------------------------------------
' Funkce k zohlednění pouze desetinných čísel
'--------------------------------------------------------------------------
Private Function TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Select Case iKeyCode
' Povolit následující znaky:
' 8 Klávesa Backspace k opravám
' 48-57 Čísla od 0 do 9
' 96-105 Čísla od 0 do 9 (číselná klávesnice)
' 37, 39 Klávesy kurzoru ()
' 46 Klávesa pro vymazání
Case 48 To 57, 8, 96 To 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' Na první pozici povolit pouze znaménko mínus
' 109 Mínus (číselná klávesnice)
' 189 Mínus
Case 109, 189:
If InStr(1, objTextBox, "-", vbTextCompare) > 0 Or objTextBox.SelStart <> 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' Povolit pouze čárku nebo tečku a nahradit tečku čárkou
' 188 Čárka
' 110 Čárka (číselná klávesnice)
' 190 Tečka
Case 190, 188, 110:
If InStr(1, objTextBox, ",", vbTextCompare) > 0 Or objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorovat všechny ostatní znaky
Case Else: TxT_KeyDown = 0
End Select
End Function

'--------------------------------------------------------------------------
' Pro zadávání souřadnice X povolit pouze desetinná čísla
'--------------------------------------------------------------------------
Private Sub txbX_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Pro zadávání souřadnice Y povolit pouze desetinná čísla
'--------------------------------------------------------------------------
Private Sub txbY_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Pro zadávání souřadnice Z povolit pouze desetinná čísla
'--------------------------------------------------------------------------
Private Sub txbZ_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Pro zadávání počtu kopií povolit pouze celá čísla
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Select Case iKeyCode
' Povolit pouze čísla 0-9
Case 48 To 57
' Ignorovat všechny ostatní znaky
Case Else: iKeyCode = 0
End Select
End Sub

Posun a kopie pomocných linií

Následně je uveden zdrojový text pro posun a kopii vybraných pomocných linií. Jednotlivé kroky jsou vysvětleny v komentářích.

Option Explicit

Enum Errors
Err_RFEM = 513 ' RFEM není otevřený
Err_Model = 514 ' Neotevřel se žádný model
Err_Guideline = 515 ' Nejsou k dispozici žádné pomocné linie
Err_Guideline_sel = 516 ' Nebyly vybrány pomocné linie
End Enum

'--------------------------------------------------------------------------
' Postup k posunutí a kopírování vybraných pomocných linií
'--------------------------------------------------------------------------
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

' Přepnout na rozhraní k programu RFEM 
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Odstranit chyby, pokud se program RFEM neotevřel
Err.Raise Errors.Err_RFEM
End If

' Zablokovat COM licenci a přístup k programu
app.LockLicense

' Přepnout na rozhraní k aktivnímu modelu
If app.GetModelCount > 0 Then
Set model = app.GetActiveModel
Else
' Odstranit chyby, pokud se neotevřel model
Err.Raise Errors.Err_Model
End If

' Přepnout na rozhraní k pomocným liniím
Set guides = model.GetGuideObjects

' Určit počet pomocných linií
model.GetModelData.EnableSelections (False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 Then
' Odstranit chyby, pokud nejsou k dispozici pomocné linie
Err.Raise Errors.Err_Guideline
End If
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No

' Určit počet vybraných pomocných linií
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount

If iCountSel > 0 Then
' Kopírování vybraných pomocných linií
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
' Založit novou pracovní rovinu, pokud se má pomocná linie kopírovat do jiné pracovní roviny
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
' Pomocné linie ve stejné pracovní rovině
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
' Souřadnice pomocných linií (X, Y, Z) se přizpůsobí vektoru posunu 
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
' Posunutí vybraných pomocných linií
Else
For i = 0 To iCountSel - 1
' Posunout pomocné linie do jiné pracovní roviny
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
' Souřadnice pomocných linií (X, Y, Z) se přizpůsobí vektoru posunu.
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
' Odstranit chybu, pokud se nevybraly pomocné linie
Err.Raise Errors.Err_Guideline_sel
End If

' Ošetření chyb
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case Errors.Err_RFEM
MsgBox ("RFEM se neotevřel")
Exit Sub
Case Errors.Err_Model
MsgBox ("Neotevřel se žádný soubor!")
Case Errors.Err_Guideline
MsgBox ("V souboru nejsou k dispozici žádné pomocné linie" & model.GetName & "!")
Case Errors.Err_Guideline_sel
MsgBox ("V souboru nejsou vybrány žádné pomocné linie" & model.GetName & " !")
Case Else
MsgBox "Fehler-Nr. : " & Err.Number & vbLf & Err.Description
End Select
End If
' Uvolněna COM licence, přístup k programu obnoven
app.UnlockLicense

Set app = Nothing
Set model = Nothing
Set guides = Nothing

End Sub

'--------------------------------------------------------------------------
' Spuštění
'--------------------------------------------------------------------------
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub

'--------------------------------------------------------------------------
' Funkce, která zjistí, je-li otevřen program RFEM
'--------------------------------------------------------------------------
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

Shrnutí a výhled do budoucna

V příspěvku byl vyvinut nástroj na posunu/kopii pomocných linií v programu RFEM. Analogicky by mohl být vyvinut obdobný nástroj pro program RSTAB. Nástroj se spouští v programu MS Excel. Lze uvažovat také o integraci tohoto nástroje do prostředí programu RFEM nebo RSTAB, tak jak je popsáno v tomto příspěvku.

Ke stažení

Odkazy

Kontakt

Kontakt

Máte dotazy nebo potřebujete poradit?
Kontaktujte nás nebo využijte stránky s často kladenými dotazy.

+420 227 203 203

info@dlubal.cz

RFEM Hlavní program
RFEM 5.xx

Hlavní program

Program RFEM pro statické výpočty metodou konečných prvků umožňuje rychlé a snadné modelování konstrukcí, které se skládají z prutů, desek, stěn, skořepin a těles. Pro následná posouzení jsou k dispozici přídavné moduly, které zohledňují specifické vlastnosti materiálů a podmínky uvedené v normách.

Cena za první licenci
3 540,00 USD
RSTAB Hlavní program
RSTAB 8.xx

Hlavní program

Program pro statický výpočet a navrhování prutových a příhradových konstrukcí, provedení lineárních a nelineárních výpočtů vnitřních sil, deformací a podporových reakcí.

Cena za první licenci
2 550,00 USD
RFEM Ostatní
RF-COM 5.xx

Přídavný modul

Programovatelné rozhraní COM

Cena za první licenci
580,00 USD