Vložení odkazu
Die RFEM-Objektbibliothek ist zunächst im VBA-Editor über "Extras" → "Verweise" einzubinden.
vstupní dialogy
Vstupní tabulka slouží k zadávání vektoru posunu a počtu kopií. Pro vytvoření vstupní tabulky se vygeneruje uživatelský formulář pomocí příkazu "Vložit" → "UserForm" ve VBA editoru. 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í.
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.
- code.py#
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 txbNum.Value = "" Pak
txbNumber.Value = 0
End If
If txbX.Value = "" Pak
txbX.Value = 0
End If
If txbY.Value = "" Pak
txbY.Value = 0
End If
If txbZ.Value = "" Pak
txbZ.Value = 0
End If
Vyvolání modGuideline.SetGuidelines(txbAnz.Value, txbX.Value, txbY.Value, txbZ.Value)
frmGuideline.Hide
End Sub
'-------------------------------------------- --------------------------
' Funkce k zohlednění pouze desetinných čísel
'-------------------------------------------- --------------------------
Soukromá funkce TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
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 až 57, 8, 96 až 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 Or objTextBox.SelStart = 0 Pak
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorovat všechny ostatní znaky
Případ jiný: TxT_KeyDown = 0
Konec Vybrat
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)
Vyberte případ iKeyCode
' Povolit pouze čísla 0-9
Případ 48 až 57
' Ignorovat všechny ostatní znaky
Případ jiný: iKeyCode = 0
Konec Vybrat
End Sub
- /kód#
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.
- code.py#
Option Explicit
Výčet chyb
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í
'-------------------------------------------- --------------------------
SubSadaGuidelines (iNo. As Integer, dNodeX, dNodeY, dNodeZ As Double)
Dim model As RFEM5.model
Aplikace Dim As RFEM5.Application
Vodicí linie dim jako IGuideObjects
Dim lines() Jako vodicí linie
Dim iCountAll, iCountSel, i, iAnzCopy, iGuideNo As Integer
Dim newLayerLinie As Guideline
On Error Přejít do Error Handler
' 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 Pak
Nastavit 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
Nastavit vodicí linie = model.GetGuideObjects
' Určit počet pomocných linií
model.GetModelData.EnableSelections (False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
Pokud je iCountAll = 0, pak
' 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
Pokud je iCountSel > 0, pak
' Kopírování vybraných pomocných linií
vodítek.PrepareModification
linie = guides.GetGuidelines()
Pokud iNumber > 0 Pak
Pro iČ.Kopírovat = 1 Do iČ
Pro 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 A dNodeZ <> 0) Pak
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).Poloměr
' Souřadnice vodicí linie (X, Y, Z) kopie se upraví pomocí 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 = "Kopírovat vodicí linii " + CStr(lines(i).No)
vodicí linie.NastavitPomocnou linii newLayerLine
Další
iCountAll = iCountAll + iCountSel
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No
Další
' Posunutí vybraných pomocných linií
Else
Pro i = 0 To iCountSel - 1
' Posunout pomocné linie do jiné pracovní roviny
If (lines(i) .WorkPlane = PlaneXY A dNodeZ <> 0) Pak
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 vodicí linie (X, Y, Z) se upraví pomocí vektoru posunu
linie(i).Bod1.X = linie(i).Bod1.X + dUzelX
linie(i).Bod1.Y = linie(i).Bod1.Y + dUzelY
linie(i).Bod1.Z = linie(i).Bod1.Z + dUzelZ
linie(i).Bod2.X = linie(i).Bod2.X + dUzelX
linie(i).Bod2.Y = linie(i).Bod2.Y + dUzelY
linie(i).Bod2.Z = linie(i).Bod2.Z + dUzelZ
Další
vodicí linie.SetGuidelines linie
End If
vodicí linie.DokončitÚpravu
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
Vyberte stav ChybaNumber
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 & " !")
Případ Else
MsgBox "Chyba č. : " & Err.Number & vbLf & Err.Description
Konec Vybrat
End If
' Uvolněna COM licence, přístup k programu obnoven
app.UnlockLicense
Set app = nic
Set model = Nothing
Nastavit vodicí linie = nic
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á
Dim objWMI, colPro As Object
Set objWMI = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")
Nastavit colPro = objWMI.ExecQuery_
("Vybrat * z Win32_Process, kde Name = 'RFEM64.exe'")
If colPro.Count = 0 Pak
RFEM_open = False
Else
RFEM_open = True
End If
End Function
- /kód#
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. Tento nástroj je také možné integrovat do programu RFEM nebo RSTAB, jak je popsáno v tomto článku: