'Programm von Kai Brossi zur generierung von VG-Röhren

Option Explicit

'Globale  Variablen Deklaration ---------------------------------------------------------------------------------------

    ' Objekte
      Dim Flansch1 As Object
      Dim Flansch2 As Object
      Dim Zylinder As Object
      Dim Attribut As Object
        
    ' Punkte
      Dim startPnt As Variant
      Dim endPnt As Variant
      Dim einfPnt(0 To 2) As Double
      Dim länge As Double
      Dim effL As Double
      Dim WinkelXY As Double
      Dim WinkelZ As Double
      
    ' Konstante
      
        'PI
        Public Function PI() As Variant
            PI = 4# * CDec(Atn(1))
        End Function
        
        'Bogenmass
        Public Function bMass() As Double
            bMass = (2 * PI) / 360
        End Function
        


'Hauptprogramm -------------------------------------------------------------------------------------------------------


Sub Acad_VG3_Generator()
    
    Punkte
    If effL < 801 Then
      Call Beenden
    Else
      Call Einfügen
      Call Blockerstellen
    End If
    Beenden

End Sub



'Funktionen

'Abfrage Punkte ------------------------------------------------------------------------------------------------
    
    Function Punkte()
       
    On Error GoTo ErrorExit

    Dim Pnt1 As Variant
    Dim kList As String
    Dim keyw As String
    
      ' Setzte Startpunkt mit Promt
      startPnt = ThisDrawing.Utility.GetPoint(, "Startpunkt in Weltkoordinaten oder Punkt wählen: ")
    
      ' Deklariere Schlüsselwörter
      kList = "Länge Endpunkt"
      
      ' Schlüsselwörter setzten
      ThisDrawing.Utility.InitializeUserInput 128, kList
      
      ' Schlüsselwörter auslesen
      keyw = ThisDrawing.Utility.GetKeyword("Option wählen [Länge, Endpunkt]: ")
      
      ' Schlüsselwörter interpretieren
      Select Case keyw
      Case "Länge"
         länge = ThisDrawing.Utility.GetDistance(, "Bitte Länge eingeben: ")
         Bestimmung
      Case "Endpunkt"
         endPnt = ThisDrawing.Utility.GetPoint(, "Endpunkt eingeben in Weltkoordinaten oder Punkt wählen: ")
         Berechnen
      Case Else
         Call Fehler
      End Select
      
ErrorExit:
Beenden

    End Function
    
    
'Abfrage Endpunkt oder Länge -------------------------------------------------------------------------------------
    
    Function Bestimmung()
    Dim Pnt2(0 To 2) As Double
    
         ' Längenpunkt bestimmen
         Pnt2(0) = startPnt(0): Pnt2(1) = startPnt(1): Pnt2(2) = startPnt(2) + länge
         endPnt = Pnt2
         Berechnen
         
    End Function
    
    
'Abfrage Endpunkt oder Länge -------------------------------------------------------------------------------------
    
    Function Berechnen()
    Dim deltaX As Double
    Dim deltaY As Double
    Dim deltaZ As Double
    Dim L1 As Double
      
         'Delta ausrechnen
         deltaX = endPnt(0) - startPnt(0)
         deltaY = endPnt(1) - startPnt(1)
         deltaZ = endPnt(2) - startPnt(2)
         
         'Längenberechnung
         L1 = Sqr(deltaX ^ 2 + deltaY ^ 2)
         effL = Sqr(L1 ^ 2 + deltaZ ^ 2)
         
         'Abfrage Effektive länge >= 801
         If effL < 801 Then
            Call zuklein
            Call Beenden
            GoTo Halt
         End If
         
         'Abfage auf alle Null
         If (deltaX = 0 And deltaY = 0 And deltaZ = 0) Then
           Call gleichePnt
           Call Beenden
           GoTo Halt
         End If
         
         'Winkel XY bestimmen
         If deltaX > 0 And deltaY > 0 Then WinkelXY = Atn(deltaY / deltaX)
            
         If deltaX < 0 And deltaY > 0 Then WinkelXY = -Atn(deltaX / deltaY) + (PI / 2)
            
         If deltaX < 0 And deltaY < 0 Then WinkelXY = Atn(deltaY / deltaX) + PI
            
         If deltaX > 0 And deltaY < 0 Then WinkelXY = -Atn(deltaX / deltaY) + (3 * PI) / 2
            
         If deltaX = 0 And deltaY > 0 Then WinkelXY = (PI / 2)
            
         If deltaX = 0 And deltaY < 0 Then WinkelXY = (3 * PI) / 2
            
         If deltaY = 0 And deltaX > 0 Then WinkelXY = 0
            
         If deltaY = 0 And deltaX < 0 Then WinkelXY = PI
            
         If deltaX = 0 And deltaY = 0 Then WinkelXY = 0
         
         'Winkel in Z bestimmen
         If L1 = 0 Then
            WinkelZ = PI / 2
         ElseIf L1 = effL Then
               WinkelZ = 0
             Else
               WinkelZ = Atn(deltaZ / L1)
         End If
   
         'Ausgabe in MBox
         MsgBox "Winkel XY: " & WinkelXY & ", Winkel Z: " & WinkelZ & ", Länge XY: " & L1 & ", Länge Z: " & effL
         
         
Halt:
    End Function


'Funktion Einfügen-----------------------------------------------------------------------------------------------------

    Function Einfügen()
    Dim bRotation As Double
    Dim bWinkel As Double
    Dim center(0 To 2) As Double
    Dim center2(0 To 2) As Double
    Dim radius As Double
    Dim Grösse As String
    Dim Pnt2(0 To 2) As Double
      
      'Text für Attribut
      Grösse = "VG Länge"
      
      'Angabe des Basiswinkels
      bWinkel = 90
      
      'Berechnung des Bogenmasses
      bRotation = bMass * bWinkel
      
      'Einsatzpunkt 2
      einfPnt(0) = startPnt(0) + effL: einfPnt(1) = startPnt(1): einfPnt(2) = startPnt(2)
      
      'Radius Zylinder
      radius = 265.5
      
      'Mittelpunkt Zylinder
      center(0) = startPnt(0) + (effL / 2): center(1) = startPnt(1): center(2) = startPnt(2)
      center2(0) = startPnt(0) + (effL / 2): center2(1) = startPnt(1) + 1: center2(2) = startPnt(2)
      
      'Setze Objekt ein
      Set Flansch1 = ThisDrawing.ModelSpace.InsertBlock(startPnt, "C:\Makros\Blöcke\VG3.dwg", 1#, 1#, 1#, bRotation)
      Set Flansch2 = ThisDrawing.ModelSpace.InsertBlock(einfPnt, "C:\Makros\Blöcke\VG3.dwg", 1#, 1#, 1#, bRotation + PI)
      Set Zylinder = ThisDrawing.ModelSpace.AddCylinder(center, radius, effL - 700)
      Set Attribut = ThisDrawing.ModelSpace.AddAttribute(2.5, acAttributeModeInvisible, "Länge in mm", startPnt, "VG3 Länge", effL)
      
      'Drehen Zylinder ausrichten
      Zylinder.Rotate3D center, center2, PI / 2
    
      '2.Achsenpunkt bestimmen
      Pnt2(0) = startPnt(0): Pnt2(1) = startPnt(1) + 100: Pnt2(2) = startPnt(2)
      
      'Drehen um die Y-Achse
      Flansch1.Rotate3D startPnt, Pnt2, -WinkelZ
      Flansch2.Rotate3D startPnt, Pnt2, -WinkelZ
      Zylinder.Rotate3D startPnt, Pnt2, -WinkelZ
      Attribut.Rotate3D startPnt, Pnt2, -WinkelZ
      
      'Drehen um die Z-Achse
      Flansch1.Rotate startPnt, WinkelXY
      Flansch2.Rotate startPnt, WinkelXY
      Zylinder.Rotate startPnt, WinkelXY
      Attribut.Rotate startPnt, WinkelXY
      
    End Function
    
    
'Block erstellen ---------------------------------------------------------------------------------------------------
    Function Blockerstellen()
    Dim Block As AcadBlock
    Dim ObjList(3) As AcadEntity
    Dim sSet As AcadSelectionSet, ToPoint(2) As Double
    
    On Error Resume Next
    
      Set Block = ThisDrawing.Blocks.Add(startPnt, "test")
    
      Set ObjList(0) = Flansch1
      Set ObjList(1) = Flansch2
      Set ObjList(2) = Zylinder
      Set ObjList(3) = Attribut
      
      
      ReDim ObjList(s.Set.Count - 1) As Object
      For i = 0 To sSet.Count - 1
         Set ObjList(i) = sSet.Item(i)
      Next
      CopyObjects ObjList, Block, IdPairs
      FromPoint = Object.insertionPoint
      For i = 0 To UBound(IdPairs)
         If IdPairs(i).IsPrimary = True Then
            Set Obj = ObjectIdToObject(IdPairs(i).value)
            Obj.Move FromPoint, ToPoint
         End If
    
    End Function
    
    
'Fehler zu kleine Röhre --------------------------------------------------------------------------------------------
    Function zuklein()
         
         ' Fehler ausgabe
         MsgBox "Die VG Röhren mussen min. 801mm lang sein für kleinere benutzen Sie die VI Röhren"
    
    End Function
    
    
'Fehler gleiche Punkte --------------------------------------------------------------------------------------------
    Function gleichePnt()
         
         ' Fehler ausgabe
         MsgBox "Die beiden punkte Haben den selben Wert"
    
    End Function
    
    
'Fehler Eingabe --------------------------------------------------------------------------------------------------

    Function Fehler()
         
         ' Fehler ausgabe
         MsgBox "Fehlerhafte Eingabe! Befehl erneut starten"
    
    End Function


'Programm Ende --------------------------------------------------------------------------------------------------

    Function Beenden()
     ThisDrawing.Regen acAllViewports
    End Function