Verweis einfügen
Die RFEM-Objektbibliothek ist zunächst im VBA-Editor über "Extras" → "Verweise" einzubinden.
Eingabemaske
In der Eingabemaske sollen der Verschiebevektor sowie die Anzahl der Kopien eingegeben werden können. Im VBA-Editor wird zur Erstellung der Eingabemaske eine Userform über "Einfügen" → "UserForm" erzeugt. Danach werden die notwendigen Steuerelemente auf der Userform platziert. Dazu ist das betreffende Steuerelement in der Werkzeugsammlung auszuwählen und dann auf der Userform abzulegen. Die Eigenschaften Größe, Position, Name etc. der Userform und Steuerelemente können im Eigenschaftsfenster festgelegt werden.
Für den Verschiebevektor sollen nur Dezimalzahlen und für die Anzahl der Kopien sollen nur ganze Zahlen als Eingaben zugelassen werden. Der Quelltext der Eingabemaske ist nachstehend aufgeführt.
Option Explicit
'--------------------------------------------------------------------------
' Fenster schließen bei Klick auf Abbrechen
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
frmGuideline.Hide
End Sub
'--------------------------------------------------------------------------
' Prozedur zum Verschieben/Kopieren von Hilfslinien aufrufen und Fenster schließen bei Klick auf 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
'--------------------------------------------------------------------------
' Funktion, um nur Dezimalzahlen zuzulassen
'--------------------------------------------------------------------------
Private Function TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Select Case iKeyCode
' Folgende Zeichen zulassen:
' 8 Backspacetaste zum Korrigieren
' 48-57 Zahlen von 0 bis 9
' 96-105 Zahlen von 0 bis 9 (Nummernblock)
' 37, 39 Cursor-tasten ()
' 46 Entf-Taste
Case 48 To 57, 8, 96 To 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' Nur ein Minuszeichen an erster Position zulassen
' 109 Minus (Nummernblock)
' 189 Minus
Case 109, 189:
If InStr(1, objTextBox, "-", vbTextCompare) > 0 Or objTextBox.SelStart <> 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' Nur ein Komma oder Punkt zulassen und Punkt durch Komma ersetzen
' 188 Komma
' 110 Komma (Nummernblock)
' 190 Punkt
Case 190, 188, 110:
If InStr(1, objTextBox, ",", vbTextCompare) > 0 Or objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Alle anderen Zeichen ignorieren
Case Else: TxT_KeyDown = 0
End Select
End Function
'--------------------------------------------------------------------------
' Nur Dezimalzahlen für Eingabe der X-Koordinate zulassen
'--------------------------------------------------------------------------
Private Sub txbX_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' Nur Dezimalzahlen für Eingabe der Y-Koordinate zulassen
'--------------------------------------------------------------------------
Private Sub txbY_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' Nur Dezimalzahlen für Eingabe der Z-Koordinate zulassen
'--------------------------------------------------------------------------
Private Sub txbZ_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' Nur ganze Zahlen für Eingabe der Anzahl der Kopien zulassen
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Select Case iKeyCode
' Nur Zahlen von 0-9 zulassen
Case 48 To 57
' Alle anderen Zeichen ignorieren
Case Else: iKeyCode = 0
End Select
End SubVerschieben und Kopieren der Hilfslinien
Der Quelltext zum Verschieben und Kopieren der selektierten Hilfslinien ist nachstehend aufgeführt. Die einzelnen Schritte sind in den Kommentaren erläutert.
Option Explicit
Enum Errors
Err_RFEM = 513 ' RFEM nicht geöffnet
Err_Model = 514 ' Kein Modell geöffnet
Err_Guideline = 515 ' Keine Hilfslinien vorhanden
Err_Guideline_sel = 516 ' Keine Hilfslinien selektiert
End Enum
'--------------------------------------------------------------------------
' Prozedur zum Verschieben und Kopieren von selektierten Hilfslinien
'--------------------------------------------------------------------------
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
' Interface zu RFEM holen
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Fehler auslösen, falls RFEM nicht geöffnet ist
Err.Raise Errors.Err_RFEM
End If
' COM-Lizenz und Programmzugriff sperren
app.LockLicense
' Interface zum aktiven Modell holen
If app.GetModelCount > 0 Then
Set model = app.GetActiveModel
Else
' Fehler auslösen, falls kein Modell geöffnet ist
Err.Raise Errors.Err_Model
End If
' Interface zu Hilfslinien holen
Set guides = model.GetGuideObjects
' Anzahl der Hilfslinien bestimmen
model.GetModelData.EnableSelections (False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 Then
' Fehler auslösen, falls keine Hilfslinien vorhanden sind
Err.Raise Errors.Err_Guideline
End If
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No
' Anzahl der selektierten Hilfslinien bestimmen
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount
If iCountSel > 0 Then
' Kopieren der selektierten Hilfslinien
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
' Neue Arbeitsebene anlegen, wenn Hilfslinie in andere Arbeitsebene kopiert werden soll
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
' Hilfslinien in der selben Arbeitsebene
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
' Hilfslinienkoordinaten (X, Y, Z) der Kopie werden um den Verschiebevektor angepasst
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
' Verschieben der selektierten Hilfslinien
Else
For i = 0 To iCountSel - 1
' Hilfslinien in andere Arbeitsebene verschieben
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
' Hilfslinienkoordinaten (X, Y, Z) werden um den Verschiebevektor angepasst
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
' Fehler auslösen, falls keine Hilfslinien selektiert sind
Err.Raise Errors.Err_Guideline_sel
End If
' Fehlerbehandlung
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case Errors.Err_RFEM
MsgBox ("RFEM ist nicht geöffnet")
Exit Sub
Case Errors.Err_Model
MsgBox ("Keine Datei geöffnet!")
Case Errors.Err_Guideline
MsgBox ("Keine Hilfslinien in Datei " & model.GetName & " vorhanden!")
Case Errors.Err_Guideline_sel
MsgBox ("Keine Hilfslinien in Datei " & model.GetName & " selektiert!")
Case Else
MsgBox "Fehler-Nr. : " & Err.Number & vbLf & Err.Description
End Select
End If
' COM-Lizenz wird freigegeben, Programmzugriff wieder möglich
app.UnlockLicense
Set app = Nothing
Set model = Nothing
Set guides = Nothing
End Sub
'--------------------------------------------------------------------------
' Initialisierung
'--------------------------------------------------------------------------
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub
'--------------------------------------------------------------------------
' Funktion zur Überprüfung, ob RFEM geöffnet ist
'--------------------------------------------------------------------------
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 FunctionZusammenfassung und Ausblick
Im Beitrag wurde ein Werkzeug zum Verschieben/Kopieren von Hilfslinien in RFEM entwickelt. Analog könnte ein entsprechendes Werkzeug für RSTAB erstellt werden. Das Werkzeug wird über die Oberfläche von Excel gestartet. Denkbar wäre auch die Einbindung dieses Werkzeugs in die Oberfläche von RFEM oder RSTAB wie in diesem Betrag beschrieben: