Rozhraní COM ve VBA | 5. Vytvoření nástroje pro kopírování a posun vodicích linií

Vložení odkazu

Die RFEM-Objektbibliothek ist zunächst im VBA-Editor über "Extras" → "Verweise" einzubinden.

Vložit RFEM Type Library

Vstupní tabulka

Vstupní tabulka slouží k zadávání vektoru posunu a počtu kopií. Pro vytvoření vstupní tabulky se v editoru VBA vytvoří 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í.

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.
'------------------------------------------------- -------------------------
Soukromé 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
'------------------------------------------------- -------------------------
Soukromé cmdOK_Click ()
If txbAnz.Value = "" Následně
txbAnz.Value =

Vstupní tabulka

'------------------------------------------------- -------------------------
' Funkce k zohlednění pouze desetinných čísel
'------------------------------------------------- -------------------------
Soukromá funkce TxT_KeyDown (objTextBox As MSForms.TextBox, iKeyCode Jako celé číslo)Jako celé číslo
Vyberte případ 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í
Případ 48 Komu 57,8,96 Komu 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
Případ 109,189:
If InStr (1, objTextBox, "-", vbTextCompare)> 0 Nebo 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
Případ 190,188,110:
If InStr (1, objTextBox, ",", vbTextCompare)> 0 Nebo objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorovat všechny ostatní znaky
Případ jiný: TxT_KeyDown = 0
Ukončit výběr
End Function

'------------------------------------------------- -------------------------
' Pro zadávání souřadnice X povolit pouze desetinná čísla
'------------------------------------------------- -------------------------
Soukromé 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
'------------------------------------------------- -------------------------
Soukromé Sub txbY_KeyDown (ByVal iKeyCode As MSForms.ReturnInteger, ByVal PosunJako celé číslo)
iKeyCode = TxT_KeyDown (txbY, CInt(iKeyCode))
End Sub

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

'------------------------------------------------- -------------------------
' Pro zadávání počtu kopií povolit pouze celá čísla
'------------------------------------------------- -------------------------
Soukromé txbAnz_KeyPress (ByVal iKeyCode As MSForms.ReturnInteger)
Vyberte případ iKeyCode
' Povolit pouze čísla 0-9
Případ 48 Komu 57
' Ignorovat všechny ostatní znaky
Případ jiný: iKeyCode = 0
Ukončit výběr
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

Výčet Chyby
Err_RFEM = 513 'RFEM nebyl otevřen
Err_Model = 514 'Žádný model se neotevřel
Err_Guideline = 515 'Nejsou k dispozici žádné pokyny
Err_Guideline_sel = 516 'Nejsou vybrány žádné vodicí linie
End Enum

'------------------------------------------------- -------------------------
' Postup k posunutí a kopírování vybraných pomocných linií
'------------------------------------------------- -------------------------
Sub SetGuidel (iAnz Jako celé číslo, dNodeX, dNodeY, dNodeZ Jako Double)
Dim modelu As RFEM5.model
Dim cca As RFEM5.Application
Dim vodítka As IGuideObjects
Dim linie () As Směrnice
Dim iCountAll, iCountSel, i, iAnzKopie, iGuideNo Jako celé číslo
Dim newLayerLine As Směrnice

On Error GoTo Nástroj pro zpracování chyb

' Přepnout na rozhraní k programu RFEM
If RFEM_open = Pravda tedy
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
Chybové chyby Err.Raise.Err_Model
End If

' Přepnout na rozhraní k pomocným liniím
Set průvodce = 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
Chybové hlášení Err.Raise.Err_Guideline
End If
iGuideNo = průvodce.Získáte vodicí linii (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í
vodítka
řádky = vodítka.Zásady ()
If iAnz> 0 Then
Krátký dotaz - rychlá odpověď: iAnzKopie = 1 Komu iAnz
Krátký dotaz - rychlá odpověď: i = 0 Komu iCountSel - 1
newLayerLine.WorkPlane = linie (i) .WorkPlane
' Založit novou pracovní rovinu, pokud se má pomocná linie kopírovat do jiné pracovní roviny
If (linie (i) .WorkPlane = PlaneXY A ... dNodeZ <>

Vstupní tabulka

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
'------------------------------------------------- -------------------------
Funkce RFEM_open () Jako booleovský jazyk
Dim objWM, colPro Jako objekt

Set objWMI = GetObject ("winmgmts:" _
& "{impersonationLevel = impersonate}! \\" & "." & "\ root \ cimv2")
Set colPro = objWMI.ExecQuery _
("Vybrat * z programu 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

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. Jak je popsáno v tomto článku, můžeme tento nástroj také začlenit do programu RFEM nebo RSTAB.