Option Explicit

'--------------------------------------------------------------------------
' Fenster schlieen bei Klick auf Abbrechen
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
 frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Prozedur zum Verschieben/ Kopieren von Hilfslinien aufrufen und Fenster schlieen 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 (<- und ->)
  ' 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 fr 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 fr 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 fr 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 fr 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

Option Explicit

Enum Errors
 Err_RFEM = 513          'RFEM nicht geffnet
 Err_Model = 514         'kein Modell geffnet
 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 auslsen, falls RFEM nicht geffnet 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 auslsen, falls kein Modell geffnet 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 auslsen, 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 gleichen 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 auslsen, 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 geffnet")
     Exit Sub
    Case Errors.Err_Model
     MsgBox ("Keine Datei geffnet!")
    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 mglich
 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 berprfung, ob RFEM geffnet 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