' Publications-------------------------------------------------------------------
Public CancelVar1
 
'Grunddeklarationen--------------------------------------------------------------
Dim documents1 As Documents
Dim partDocument1 As PartDocument
Dim part1 As Part
Dim HB1 As HybridBodies, HB2 As HybridBodies, HB3 As HybridBodies, HB4 As HybridBodies
Dim Design, SAchse, SPosition, Tuer As HybridBody


  
Dim Wzk3DH As HybridShapeFactory                                'Werkzeugkasten

Dim hybridShapeFactory1 As HybridShapeFactory
Dim Eben_umX, Ebene_umY As HybridShapePlaneAngle
Dim X_Achse, Y_Achse, ScharAchse, ScharPunkt As HybridShapeIntersection
 
 
'Referenzen
Dim ref1, ref2, ref3, X, y, z As Reference
Dim Intersectx, Intersecty As Reference
Dim NeigungX, NeigungY, AchseX, AchseY As Reference
Dim NeigungNX, NeigungNY As Reference
 
'---Originalebenen deklarieren---
Dim PlaneYZ, PlaneZX, PlaneXY As HybridShapePlaneExplicit
 
'---Parameter Deklaration---
 
Dim AbstandX, AbstandY, AbstandZ, SAbstand As Length
Dim NWinkel1, NWinkel2 As Angle
Dim Tuerauf As Double
 
 
 
 
 
Sub CATMain()
 
'--------------------------------------------------------------------------------
'Grunddeklaration----------------------------------------------------------------
 
Set documents1 = CATIA.Documents
Set partDocument1 = documents1.Item("ADAPTER.CATPart")
Set part1 = partDocument1.Part
Set HB1 = part1.HybridBodies
Set Wzk3DH = part1.HybridShapeFactory
 
'---GeoSet erzeugen---
Set Design = HB1.Add
Design.Name = "Design"
 
'---------------------------------------------------------------------------------
'Untersuchung starten-------------------------------------------------------------
 
Dim Msg, Style, Title, Response, MyString
Msg = "Untersuchung starten ?"    ' Define message.
Style = vbYesNo   ' Define buttons.
Title = "MsgBox"    ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
    MyString = "Yes"    ' Bei Ja wird ein neues Fenster eingeblendet
 
 
'--------------------------------------------------------------------------------
'Öffnen der Tabelle und verändern dieser-----------------------------------------
 
Dim objXL As Object
Dim WB As Workbook
Dim WS As Worksheet
Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
Set WB = objXL.Workbooks.Open("K:\G_Projekte\Projekte_Team_Rohbau\Tueren BY624\Diplomarbeit_Viktoria\Parametereingabe.xls") ' Arbeitsmappe öffnen
Set WS = WB.Worksheets.Item(1) ' Tabelle holen
 
'objXL.ActiveWorkbook.Save

'objXL.Close

'Excel.Application.EnableEvents = False
'Excel.ActiveWorkbook.Save
'Excel.Application.EnableEvents = True
''ExcelTest.Workbooks("test.xls").Save'
''Excel.workbooks.Close  'SaveChanges:=True

'Achtung hier  die Zuweisung der Zellen sein!-----------------------------------
 
AbstandX = CDbl(WS.Cells(1, 2).Value)
AbstandY = CDbl(WS.Cells(2, 2).Value)
AbstandZ = CDbl(WS.Cells(3, 2).Value)
NWinkel_1 = CDbl(WS.Cells(4, 2).Value)
NWinkel_2 = CDbl(WS.Cells(5, 2).Value)
Scharnierabstand = CDbl(WS.Cells(6, 2).Value)
ScharWinkel = CDbl(WS.Cells(7, 2).Value)
Tuerauf = CDbl(WS.Cells(8, 2).Value)
 
objXL.Quit
part1.Update
 
'-------------------------------------------------------------------------------
'Scharnierpositionierung
'-------------------------------------------------------------------------------
 
Set HB2 = HB1.Item("Design")
Set SAchse = HB2.Add
SAchse.Name = "Scharnierachse"
 
part1.UpdateObject HB2
 
'-------------------------------------------------------------------------------
'---Ebenen erzeugen---
Set hybridShapeFactory1 = part1.HybridShapeFactory
 
Dim originElements1 As OriginElements
Set originElements1 = part1.OriginElements
 
 
Set PlaneYZ = originElements1.PlaneYZ
 
Set ref1 = part1.CreateReferenceFromObject(PlaneYZ)
 
Dim Ebene_in_X As HybridShapePlaneOffset
Set Ebene_in_X = hybridShapeFactory1.AddNewPlaneOffset(ref1, AbstandX, False)
Ebene_in_X.Name = "Ebene_in_X"
 
SAchse.AppendHybridShape Ebene_in_X
 
part1.InWorkObject = Ebene_in_X
 
part1.Update
 
Set PlaneZX = originElements1.PlaneZX
Set ref2 = part1.CreateReferenceFromObject(PlaneZX)
 
Dim Ebene_in_Y As HybridShapePlaneOffset
Set Ebene_in_Y = hybridShapeFactory1.AddNewPlaneOffset(ref2, AbstandY, False)
Ebene_in_Y.Name = "Ebene_in_Y"
 
SAchse.AppendHybridShape Ebene_in_Y
 
part1.InWorkObject = Ebene_in_Y
 
part1.Update
 
Set PlaneXY = originElements1.PlaneXY
Set ref3 = part1.CreateReferenceFromObject(PlaneXY)
 
Dim Ebene_in_Z As HybridShapePlaneOffset
Set Ebene_in_Z = hybridShapeFactory1.AddNewPlaneOffset(ref3, AbstandZ, False)
Ebene_in_Z.Name = "Ebene_in_Z"
 
SAchse.AppendHybridShape Ebene_in_Z
 
part1.InWorkObject = Ebene_in_Z
 
part1.Update
 
'Intersect von Ebenen---
Set X = part1.CreateReferenceFromObject(Ebene_in_X)
Set y = part1.CreateReferenceFromObject(Ebene_in_Y)
Set z = part1.CreateReferenceFromObject(Ebene_in_Z)
 
Set X_Achse = hybridShapeFactory1.AddNewIntersection(y, z)
X_Achse.Name = "X_Achse"
 
X_Achse.PointType = 0
 
SAchse.AppendHybridShape X_Achse
 
part1.InWorkObject = X_Achse 'In work
 
Set Y_Achse = hybridShapeFactory1.AddNewIntersection(X, z)
Y_Achse.Name = "Y_Achse"
 
Y_Achse.PointType = 0
 
SAchse.AppendHybridShape Y_Achse
 
part1.InWorkObject = Y_Achse
 
part1.Update
 
'---Scharnierpunkt unten---
Set Intersectx = part1.CreateReferenceFromObject(X_Achse)
Set Intersecty = part1.CreateReferenceFromObject(Y_Achse)
 
Set ScharPunkt = hybridShapeFactory1.AddNewIntersection(Intersectx, Intersecty)
ScharPunkt.Name = "Scharnierpunkt"
 
ScharPunkt.PointType = 0
 
SAchse.AppendHybridShape ScharPunkt
 
part1.InWorkObject = ScharPunkt 'In work
 
 
'---Neigungsebenen erzeugen---
Set NeigungX = part1.CreateReferenceFromObject(Ebene_in_X) 'Reference
Set NeigungY = part1.CreateReferenceFromObject(Ebene_in_Y)
Set AchseX = part1.CreateReferenceFromObject(X_Achse)    'Achse
Set AchseY = part1.CreateReferenceFromObject(Y_Achse)
 
 
Dim Neigung_um_X As HybridShapePlaneAngle
Set Neigung_um_X = hybridShapeFactory1.AddNewPlaneAngle(NeigungY, AchseX, NWinkel_1, False)
Neigung_um_X.Name = "Neigung_um_X"
 
SAchse.AppendHybridShape Neigung_um_X
part1.InWorkObject = Neigung_um_X
 
 
Dim Neigung_um_Y As HybridShapePlaneAngle
Set Neigung_um_Y = hybridShapeFactory1.AddNewPlaneAngle(NeigungX, AchseY, NWinkel_2, False)
Neigung_um_Y.Name = "Neigung_um_Y"
 
SAchse.AppendHybridShape Neigung_um_Y
 
part1.InWorkObject = Neigung_um_Y
part1.Update
 
 
'---Scharnierachse erzeugen---
Set IntersectNx = part1.CreateReferenceFromObject(Neigung_um_X)
Set IntersectNy = part1.CreateReferenceFromObject(Neigung_um_Y)
 
 
Set ScharAchse = hybridShapeFactory1.AddNewIntersection(IntersectNx, IntersectNy)
ScharAchse.Name = "Achse"
 
ScharAchse.PointType = 0
 
SAchse.AppendHybridShape ScharAchse
 
part1.InWorkObject = ScharAchse 'In work
part1.Update
 
'---Scharnierabstand festlegen---
 
Dim RefCurve, RefPunkt As Reference
Set RefCurve = part1.CreateReferenceFromObject(ScharAchse)
Set RefPunkt = part1.CreateReferenceFromObject(ScharPunkt)
Dim ScharAbstand As HybridShapePointOnCurve
Set ScharAbstand = Wzk3DH.AddNewPointOnCurveWithReferenceFromDistance(RefCurve, RefPunkt, Scharnierabstand, False)
ScharAbstand.Name = "Scharnierabstand"
 
SAchse.AppendHybridShape ScharAbstand
 
part1.InWorkObject = ScharAbstand 'In work
 
part1.Update
 
'---Scharnierachse beschnitten---
 
Dim Linie As HybridShapeLinePtPt
Dim RefPu, RefPo As Reference
Set RefPu = part1.CreateReferenceFromObject(ScharPunkt)
Set RefPo = part1.CreateReferenceFromObject(ScharAbstand)
Set Linie = Wzk3DH.AddNewLinePtPt(RefPo, RefPu)
SAchse.AppendHybridShape Linie
Linie.Name = "Scharnierachse"
 
 
'-------------------------------------------------------------------------------
'Scharnierpositionierung
'-------------------------------------------------------------------------------
 
'Geo Set erzeugen---------------------------------------------------------------
 
Set SPosition = HB2.Add
SPosition.Name = "Scharpositionierung"
 
part1.UpdateObject HB2
 
'Axis System erzeugen---------------------------------------------------------------
'unteres Achsensystem---
 
Dim axisSystems1 As AxisSystems
Set axisSystems1 = part1.AxisSystems
 
Dim Axis1 As AxisSystem
Set Axis1 = axisSystems1.Add()
 
Axis1.OriginType = catAxisSystemOriginByPoint
 
Dim RefPunktAxis As Reference, RefZ As Reference, RefY As Reference
 
Set RefPunktAxis = part1.CreateReferenceFromObject(ScharPunkt) 'orientierungpunkt
Axis1.OriginPoint = RefPunktAxis
 
Axis1.XAxisType = catAxisSystemAxisSameDirection
  
Set RefY = part1.CreateReferenceFromObject(Neigung_um_X)     'Y
Axis1.YAxisDirection = RefY
Axis1.YAxisType = catAxisSystemAxisSameDirection
  
Set RefZ = part1.CreateReferenceFromObject(Linie)     'Z
Axis1.ZAxisDirection = RefZ
Axis1.ZAxisType = catAxisSystemAxisOppositeDirection
Axis1.Name = "KOS_unten"
 
part1.UpdateObject Axis1
 
'oberes Achensystem---
 
Dim Axis2 As AxisSystem
Set Axis2 = axisSystems1.Add()
 
Axis2.OriginType = catAxisSystemOriginByPoint
 
Dim RefPunktAxis2 As Reference, RefZ2 As Reference, RefY2 As Reference
 
Set RefPunktAxis2 = part1.CreateReferenceFromObject(ScharAbstand) 'orientierungpunkt
Axis2.OriginPoint = RefPunktAxis2
 
Axis2.XAxisType = catAxisSystemAxisSameDirection        'X

Set RefY2 = part1.CreateReferenceFromObject(Neigung_um_X)     'Y
Axis2.YAxisDirection = RefY2
Axis2.YAxisType = catAxisSystemAxisSameDirection
  
Set RefZ2 = part1.CreateReferenceFromObject(Linie)     'Z
Axis2.ZAxisDirection = RefZ2
Axis2.ZAxisType = catAxisSystemAxisOppositeDirection
 
Axis2.Name = "KOS_oben"
 
part1.UpdateObject Axis2
 
part1.Update

'--------------------------------------------------------------------------------
'Scharniere positionieren--------------------------------------------------------
 
Dim param_u_ut As Parameters, param_u_ot As Parameters
Set param_u_ut = part1.Parameters
Set param_u_ot = part1.Parameters
 
'Scharnier unten---
 
Dim RefS_u_ot As Reference, RefASu1 As Reference, RefASu2 As Reference
Dim AbsolutAxis As AxisSystem
 
Dim untScharnier_ot, untScharnier_ut As HybridShapeSurfaceExplicit
Set untScharnier_ot = param_u_ot.Item("S_u_ot")
Set untScharnier_ut = param_u_ut.Item("S_u_ut")

Set AbsolutAxis = axisSystems1.Item("Absolute Axis System")  'Achtung achsensystem german!

Set RefS_u_ot = part1.CreateReferenceFromObject(untScharnier_ot)
Set RefS_u_ut = part1.CreateReferenceFromObject(untScharnier_ut)

Set RefASu1 = part1.CreateReferenceFromObject(AbsolutAxis)
Set RefASu2 = part1.CreateReferenceFromObject(Axis1)

 
Dim TransU_ot, TransU_ut As HybridShapeAxisToAxis
Set TransU_ot = Wzk3DH.AddNewAxisToAxis(RefS_u_ot, RefASu1, RefASu2)
Set TransU_ut = Wzk3DH.AddNewAxisToAxis(RefS_u_ut, RefASu1, RefASu2)
 
SPosition.AppendHybridShape TransU_ot
SPosition.AppendHybridShape TransU_ut

TransU_ot.Name = "S_u_bew"
TransU_ut.Name = "S_u_fix"

 
part1.Update
 
'Scharnier ---
 
Dim param_o_ut As Parameters, param_o_ot As Parameters
Set param_o_ut = part1.Parameters
Set param_o_ot = part1.Parameters
 
'Scharnier oben---
 
Dim RefS_o_ot As Reference, RefASo1 As Reference, RefASo2 As Reference
 
Dim obScharnier_ot, obScharnier_ut As HybridShapeSurfaceExplicit
Set obScharnier_ot = param_o_ot.Item("S_o_ot")
Set obScharnier_ut = param_o_ut.Item("S_o_ut")
 
Set AbsolutAxis = axisSystems1.Item("Absolute Axis System")
Set RefS_o_ot = part1.CreateReferenceFromObject(obScharnier_ot)
Set RefS_o_ut = part1.CreateReferenceFromObject(obScharnier_ut)
Set RefASo1 = part1.CreateReferenceFromObject(AbsolutAxis)
Set RefASo2 = part1.CreateReferenceFromObject(Axis2)
 
Dim TransO_ot, TransO_ut As HybridShapeAxisToAxis
Set TransO_ot = Wzk3DH.AddNewAxisToAxis(RefS_u_ot, RefASo1, RefASo2)
Set TransO_ut = Wzk3DH.AddNewAxisToAxis(RefS_u_ut, RefASo1, RefASo2)
 
SPosition.AppendHybridShape TransO_ot
SPosition.AppendHybridShape TransO_ut

TransO_ot.Name = "S_o_bew"
TransO_ut.Name = "S_o_fix"

 
part1.Update

'---Scharnieröffnungswinkel---
'__Achse__

Dim RefDrehachseU As Reference
Set RefDrehachseU = part1.CreateReferenceFromObject(Linie)

Dim DrehU_ot As Reference
Set DrehU_ot = part1.CreateReferenceFromObject(TransU_ot)

Dim RotateU As HybridShapeRotate
Set RotateU = Wzk3DH.AddNewEmptyRotate()
 
RotateU.Name = "bew_u"
RotateU.AngleValue = 90 - ScharWinkel
RotateU.Axis = RefDrehachseU
RotateU.ElemToRotate = DrehU_ot
RotateU.VolumeResult = False
RotateU.RotationType = 0

SPosition.AppendHybridShape RotateU
part1.InWorkObject = RotateU
part1.Update


Dim RefDrehachseO As Reference
Set RefDrehachseO = part1.CreateReferenceFromObject(Linie)
Dim DrehO_ot As Reference
Set DrehO_ot = part1.CreateReferenceFromObject(TransO_ot)

Dim RotateO As HybridShapeRotate
Set RotateO = Wzk3DH.AddNewEmptyRotate()
 
RotateO.Name = "bew_o"
RotateO.AngleValue = 90 - ScharWinkel
RotateO.Axis = RefDrehachseO
RotateO.ElemToRotate = DrehO_ot
RotateO.VolumeResult = False
RotateO.RotationType = 0

SPosition.AppendHybridShape RotateO
part1.InWorkObject = RotateO
part1.Update

'Scharnierezusammenfügen---
'unten

Dim refU_bew As Reference, refU_fix As Reference
Set refU_fix = part1.CreateReferenceFromObject(TransU_ut)
Set refU_bew = part1.CreateReferenceFromObject(RotateU)

Dim S_Unten As HybridShapeAssemble
Set S_Unten = hybridShapeFactory1.AddNewJoin(refU_fix, refU_bew)

S_Unten.SetConnex 0

S_Unten.SetManifold 0

S_Unten.SetSimplify 0

S_Unten.SetSuppressMode 0

S_Unten.SetDeviation 0.001

S_Unten.SetAngularToleranceMode 0

S_Unten.SetAngularTolerance 0.5

S_Unten.SetFederationPropagation 0

SPosition.AppendHybridShape S_Unten
S_Unten.Name = "Scharnier_unten"
part1.InWorkObject = S_Unten

part1.Update

'oben

Dim refO_bew As Reference, refO_fix As Reference
Set refO_fix = part1.CreateReferenceFromObject(TransO_ut)
Set refO_bew = part1.CreateReferenceFromObject(RotateO)

Dim S_Oben As HybridShapeAssemble
Set S_Oben = hybridShapeFactory1.AddNewJoin(refO_fix, refO_bew)

S_Oben.SetConnex 0

S_Oben.SetManifold 0

S_Oben.SetSimplify 0

S_Oben.SetSuppressMode 0

S_Oben.SetDeviation 0.001

S_Oben.SetAngularToleranceMode 0

S_Oben.SetAngularTolerance 0.5

S_Oben.SetFederationPropagation 0

SPosition.AppendHybridShape S_Oben
part1.InWorkObject = S_Oben
S_Oben.Name = "Scharnier_oben"
part1.Update
'Message
MsgBox "Scharnierachse wurde erzeugt und Scharniere  wurden positioniert"

'--------------------------------------------------------------------------------
'Grenzen
 
 Set Tuer = HB2.Add()
 Tuer.Name = "Tuer"
  
 
  
 'Tuer bei einem Untersuchungswinkel drehen--------------------------------------
 Dim ParamStrak As Parameters
 Set ParamStrak = part1.Parameters
 
 Dim Strak As HybridShapeSurfaceExplicit
 Set Strak = ParamStrak.Item("Strak")
  
 Dim RefStrak As Reference, RefDrehachse As Reference
 Set RefStrak = part1.CreateReferenceFromObject(Strak)
 Set RefDrehachse = part1.CreateReferenceFromObject(ScharAchse)
  
Dim Rotate2 As HybridShapeRotate
Set Rotate2 = Wzk3DH.AddNewEmptyRotate()
 
Rotate2.Name = "Tuer bei OpenWinkel"
Rotate2.AngleValue = (-1) * Tuerauf
Rotate2.Axis = RefDrehachse
Rotate2.ElemToRotate = RefStrak
Rotate2.VolumeResult = False
Rotate2.RotationType = 0
 
Tuer.AppendHybridShape Rotate2
 
part1.Update
 
'--------------------------------------------------------------------------------
'Hintere Grenzkurve---
 
Dim RefStrakgedreht As Reference
 
Set RefStrakgedreht = part1.CreateReferenceFromObject(Rotate2)
 
Dim HGrenzkurve As HybridShapeIntersection
Set HGrenzkurve = Wzk3DH.AddNewIntersection(RefStrak, RefStrakgedreht)
HGrenzkurve.Name = "Hintere Grenzkurve"
Tuer.AppendHybridShape HGrenzkurve
 
part1.Update

'--------------------------------------------------------------------------------
'vordere Grenzkurve

Dim P_Offset As Reference
Set P_Offset = part1.CreateReferenceFromObject(Neigung_um_X)

Dim Plane_Beschnitt As HybridShapePlaneOffset
Set Plane_Beschnitt = Wzk3DH.AddNewPlaneOffset(P_Offset, 39.4, False)
Plane_Beschnitt.Name = "Beschnittebene"

Tuer.AppendHybridShape Plane_Beschnitt

part1.Update

Dim RefBEschnitt, RefStrak_g As Reference
Set RefBEschnitt = part1.CreateReferenceFromObject(Plane_Beschnitt)
Set RefStrakg = part1.CreateReferenceFromObject(Rotate2)

Dim VG_g As HybridShapeIntersection
Set VG_g = Wzk3DH.AddNewIntersection(RefBEschnitt, RefStrakg)
VG_g.Name = "VG gedreht"

Tuer.AppendHybridShape VG_g

'Kurve zurückdrehen und mit Strak verschneiden
Dim RefVG As Reference
Set RefVG = part1.CreateReferenceFromObject(VG_g)
  
Dim RotateVG As HybridShapeRotate
Set RotateVG = Wzk3DH.AddNewEmptyRotate()
 
RotateVG.Name = "Vordere Grenzkurve"
RotateVG.AngleValue = Tuerauf
RotateVG.Axis = RefDrehachse
RotateVG.ElemToRotate = RefVG
RotateVG.VolumeResult = False
RotateVG.RotationType = 0
RotateVG.VisProperties

Tuer.AppendHybridShape RotateVG
 
part1.Update




'--------------------------------------------------------------------------------
'Nachfragen Prüfung oder Vorgabe?
 
 
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
'Was bei Vorgabe geschieht-------
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
'HG auf ZX projizieren
Dim RefHG As Reference
Set RefHG = part1.CreateReferenceFromObject(HGrenzkurve)

Dim Project1 As HybridShapeProject
Set Project1 = Wzk3DH.AddNewProject(RefHG, ref2)
Project1.SolutionType = 0
Project1.Normal = True
Project1.SmoothingType = 0
Project1.Name = "HG_projiziert"

Tuer.AppendHybridShape Project1

part1.Update

'neues Geo Set erzeugen HG Punkte
Dim HB3 As HybridBodies
Set HB3 = HB2.Item("Tuer")
Dim HGPunkte As HybridBody
Set HGPunkte = HB3.Add()
HGPunkte.Name = "Referenzpunkte_HG"
 
part1.UpdateObject HB3
part1.Update


'Punkte erzeugen

Dim RefHGProj As Reference
Set RefHGProj = part1.CreateReferenceFromObject(Project1)

Dim P1 As HybridShapePointOnCurve
Set P1 = Wzk3DH.AddNewPointOnCurveFromPercent(RefHGProj, 0#, True)
HGPunkte.AppendHybridShape P1
P1.Name = "P1"

Dim P2 As HybridShapePointOnCurve
Set P2 = Wzk3DH.AddNewPointOnCurveFromPercent(RefHGProj, 1#, True)
HGPunkte.AppendHybridShape P2
P2.Name = "P2"

part1.Update

'Extrempunkt auf HG
Dim Richtung1, Richtung2 As HybridShapeDirection
Set Richtung1 = Wzk3DH.AddNewDirection(ref1)
Set Richtung2 = Wzk3DH.AddNewDirection(ref2)

Dim Extrem1 As HybridShapeExtremum
Set Extrem1 = Wzk3DH.AddNewExtremum(RefHGProj, Richtung1, 0)
Extrem1.Direction2 = Richtung2
Extrem1.ExtremumType2 = 1
Extrem1.Name = "Extrempunkt_HG"
HGPunkte.AppendHybridShape Extrem1

part1.InWorkObject = Extrem1
part1.Update

'Geo Set Punkt Tornadolinie erzeugen

Dim HB4 As HybridBodies
Set HB4 = HB3.Item("Referenzpunkte_HG")
Dim Tornado As HybridBody
Set Tornado = HB4.Add()
Tornado.Name = "Punkt_Tornadolinie"

part1.Update
'---Verbundlinie---
 
Dim Linie1 As HybridShapeLinePtPt
Dim RefP1, RefPextrem As Reference
Set RefP1 = part1.CreateReferenceFromObject(P1)
Set RefExtrem = part1.CreateReferenceFromObject(Extrem1)
Set Linie1 = Wzk3DH.AddNewLinePtPt(RefP1, RefExtrem)
Linie1.Name = "Linie1"
Tornado.AppendHybridShape Linie1

part1.Update

'Linie  senrecht
Dim RefLinieo As Reference
Set RefLinieo = part1.CreateReferenceFromObject(Linie1)

Dim Liniesekrecht As HybridShapeLineAngle
Set Liniesenkrecht = Wzk3DH.AddNewLineAngle(RefLinieo, ref2, RefExtrem, False, 0#, 50#, 90#, False)
Liniesenkrecht.Name = "Linie2"
Tornado.AppendHybridShape Liniesenkrecht

'Extrempunkt oben
Dim RefLinie2 As Reference
Set RefLinie2 = part1.CreateReferenceFromObject(Liniesenkrecht)
Dim Richt1, Richt2 As HybridShapeDirection
Set Richt1 = Wzk3DH.AddNewDirection(RefLinie2)
Set Richt2 = Wzk3DH.AddNewDirection(ref3)

Dim Extrem2 As HybridShapeExtremum
Set Extrem2 = Wzk3DH.AddNewExtremum(RefHGProj, Richt1, 1)
Extrem2.Name = "Punkt_Tornadolinie"
Extrem2.Direction2 = Richt2
Extrem2.ExtremumType2 = 1

Tornado.AppendHybridShape Extrem2

part1.InWorkObject = Extrem2
part1.Update

'Geo Set Punkt Führungslinie erzeugen

Set HB4 = HB3.Item("Referenzpunkte_HG")
Dim Reflect As HybridBody
Set Reflect = HB4.Add()
Reflect.Name = "Punkt_Reflectlinie"

part1.Update
'---verbundlinie unten---
 
Dim Linie3 As HybridShapeLinePtPt
Dim RefP2 As Reference
Set RefP2 = part1.CreateReferenceFromObject(P2)
Set Linie3 = Wzk3DH.AddNewLinePtPt(RefExtrem, RefP2)
Reflect.AppendHybridShape Linie3
Linie3.Name = "Linie3"
part1.Update

'Linie senkrecht 2
Dim RefLinieU As Reference
Set RefLinieU = part1.CreateReferenceFromObject(Linie3)

Dim Liniesenkrecht2 As HybridShapeLineAngle
Set Liniesenkrecht2 = Wzk3DH.AddNewLineAngle(RefLinieU, ref2, RefExtrem, False, 0#, 50#, 90#, False)
Liniesenkrecht2.Name = "Linie4"
Reflect.AppendHybridShape Liniesenkrecht2

part1.Update

'Extrempunkt
Dim RefLinie3 As Reference
Set RefLinie3 = part1.CreateReferenceFromObject(Liniesenkrecht2)
Dim Richt3, Richt4 As HybridShapeDirection
Set Richt3 = Wzk3DH.AddNewDirection(RefLinie3)
Set Richt4 = Wzk3DH.AddNewDirection(ref3)

Dim Extrem3 As HybridShapeExtremum
Set Extrem3 = Wzk3DH.AddNewExtremum(RefHGProj, Richt3, 1)
Extrem3.Name = "Punkt_Reflectlinie"
Extrem2.Direction2 = Richt4
Extrem2.ExtremumType2 = 1

Reflect.AppendHybridShape Extrem3

part1.InWorkObject = Extrem3
part1.Update


'ZWISCHENPUNKT AUF DER LINIE ERZEUGEN

Dim PMitte As HybridShapePointOnCurve
Set PMitte = Wzk3DH.AddNewPointOnCurveFromPercent(RefHGProj, 0.5, True)
HGPunkte.AppendHybridShape PMitte
PMitte.Name = "PMitte"
part1.Update

'ExcelTabelle Erfahrungswerte
'Set WB = objXL.Workbooks.Open("K:\G_Projekte\Projekte_Team_Rohbau\Tueren BY624\Diplomarbeit_Viktoria\Punkterzeugung.xls") ' Arbeitsmappe öffnen
'Set WS = WB.Worksheets.Item(1)

'Excel.Application.EnableEvents = False
'Excel.ActiveWorkbook.Save
'Excel.Application.EnableEvents = True

'Werte werden hier ausgelesen
'X1 = CDbl(WS.Cells(2, 2).Value)
'X2 = CDbl(WS.Cells(3, 2).Value)
'X3 = CDbl(WS.Cells(4, 2).Value)
'X4 = CDbl(WS.Cells(5, 2).Value)
'X5 = CDbl(WS.Cells(6, 2).Value)

'objXL.Quit

'Erfahrungswerte

X1 = 15
X2 = 5
X3 = 20
X4 = 5
X5 = 20
'nacher werte nochmal ansprechen u verändern

'--------------------------------------------------------------------------------
'Geo Set TOEL erzeugen

Dim TOELPunkte As HybridBody
Set TOELPunkte = HB3.Add()
TOELPunkte.Name = "TOEL"
part1.Update

'Punkte für TOEL erzeugen
Dim RefTOELP1, RefTOELP2, RefTOELP3, RefTOELP4, RefTOELP5 As Reference
Set RefTOELP1 = part1.CreateReferenceFromObject(P1)
Set RefTOELP2 = part1.CreateReferenceFromObject(Extrem2)
Set RefTOELP3 = part1.CreateReferenceFromObject(PMitte)
Set RefTOELP4 = part1.CreateReferenceFromObject(Extrem3)
Set RefTOELP5 = part1.CreateReferenceFromObject(P2)

Dim TOELP1, TOELP2, TOELP3, TOELP4, TOELP5 As HybridShapePointCoord
Set TOELP1 = Wzk3DH.AddNewPointCoordWithReference(-X1, 0, 0, RefTOELP1)
Set TOELP2 = Wzk3DH.AddNewPointCoordWithReference(-X2, 0, 0, RefTOELP2)
Set TOELP3 = Wzk3DH.AddNewPointCoordWithReference(-X3, 0, 0, RefTOELP3)
Set TOELP4 = Wzk3DH.AddNewPointCoordWithReference(-X4, 0, 0, RefTOELP4)
Set TOELP5 = Wzk3DH.AddNewPointCoordWithReference(-X5, 0, 0, RefTOELP5)

TOELPunkte.AppendHybridShape TOELP1
TOELPunkte.AppendHybridShape TOELP2
TOELPunkte.AppendHybridShape TOELP3
TOELPunkte.AppendHybridShape TOELP4
TOELPunkte.AppendHybridShape TOELP5

TOELP1.Name = "TOELP1"
TOELP2.Name = "TOELP2"
TOELP3.Name = "TOELP3"
TOELP4.Name = "TOELP4"
TOELP5.Name = "TOELP5"
part1.Update

'Spline
Dim TOEL As HybridShapeSpline
Set TOEL = Wzk3DH.AddNewSpline()
TOELPunkte.AppendHybridShape TOEL
TOEL.Name = "TOEL"

Dim SP1, SP2, SP3, SP4, SP5 As Reference
Set SP1 = part1.CreateReferenceFromObject(TOELP1)
Set SP2 = part1.CreateReferenceFromObject(TOELP2)
Set SP3 = part1.CreateReferenceFromObject(TOELP3)
Set SP4 = part1.CreateReferenceFromObject(TOELP4)
Set SP5 = part1.CreateReferenceFromObject(TOELP5)

TOEL.AddPoint SP1
TOEL.AddPoint SP2
TOEL.AddPoint SP3
TOEL.AddPoint SP4
TOEL.AddPoint SP5
part1.Update

'Hier nochmal Excel Öffnen um die Werte zu verändern und die Spline zu aktualisieren.
 
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
'bei Prüfung---------------------------------------------------------------------
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------



 
 
End If  'bei start
 
End Sub