COM-Schnittstelle in VBA | 5. Erstellen eines Tools zum Kopieren und Verschieben von Hilfslinien

Fachbeitrag

RF-COM/RS-COM ist eine programmierbare Schnittstelle, mit der RFEM/RSTAB um auf die Bedürfnisse der Anwender zugeschnittene Eingabe- und Nachlaufprogramme ergänzt werden können. In diesem Beitrag wird ein Werkzeug für das Kopieren und Verschieben von selektierten Hilfslinien in RFEM entwickelt. Die Hilfslinien können dabei auch in eine andere Arbeitsebene kopiert oder verschoben werden. Als Programmierumgebung wird VBA in Excel verwendet.

Verweis einfügen

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

Bild 01 - Dlubal RFEM Type Library einbinden

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.

Bild 02 - Eingabemaske

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 Sub

Verschieben 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 Function

Zusammenfassung 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.

Downloads

Links

Kontakt

Kontakt zu Dlubal

Haben Sie Fragen oder brauchen Sie einen Rat? Kontaktieren Sie uns oder nutzen Sie die häufig gestellten Fragen (FAQs) rund um die Uhr.

+49 9673 9203 0

info@dlubal.com

RFEM Hauptprogramm
RFEM 5.xx

Basisprogramm

Das FEM-Programm RFEM ermöglicht die schnelle und einfache Modellierung, Berechnung und Bemessung von Tragkonstruktionen mit Stab-, Platten-, Scheiben-, Faltwerk-, Schalen- und Volumen-Elementen aus verschiedenen Materialien.

Erstlizenzpreis
3.540,00 USD
RSTAB Hauptprogramm
RSTAB 8.xx

Basisprogramm

Das 3D-Statik-Programm RSTAB eignet sich für die Berechnung von Stabwerken aus Stahl, Beton, Holz, Aluminium oder anderen Materialien. Mit RSTAB definieren Sie einfach und schnell das Tragwerksmodell und berechnen dann die Schnittgrößen, Verformungen und Lagerreaktionen.

Erstlizenzpreis
2.550,00 USD
RFEM Sonstige
RF-COM 5.xx

Zusatzmodul

Programmierbare COM-Schnittstelle

Erstlizenzpreis
580,00 USD