Programmierung/VBA Paraboloid

[Ultimate Toni]

Hey there,

ich brauche den Quelltext von der Paraboloiderstellung ausgehend von der Parabelzeichnung im Solidworks. Habs mir leider nicht geschickt und wollts zur Vorbereitung mir nochmal ansehen :blink:

Wär cool wenn es jemand reinstellen kann.

Toni

[sapphire]

Sub main()
Dim swApp As Object, swPart As Object

'Verbindung zu SolidWorks aufbauen, ins Part-Model gehen (neue Part-Datei zuvor manuell öffnen)
Set swApp = Application.SldWorks
Set swPart = swApp.ActiveDoc
'eine neue Skizze anlegen (klappt nur, wenn noch keine Skizze im Part ist)
swPart.InsertSketch2 True

'Einstellungen ändern zum Zeichnen
swPart.ViewZoomTo2 0, 0, 0, 0.005, 0.005, 0
swApp.SetUserPreferenceToggle swSketchAutomaticRelations, False

XStart = InputBox("Startwert für Intervall eingeben XStart = ")
XEnd = InputBox("Endwert für Intervall eingeben XEnd=")
SchrittWeite = InputBox("Schrittweite für Funktionswertberechnung eingeben SchrittWeite=")

X_alt = XStart
Do While X_neu + SchrittWeite <= XEnd
  Y_alt = X_alt ^ 2
Debug.print X alt
Debug.Print Y alt
  X_neu = X_alt + SchrittWeite
  Y_neu = X_neu ^ 2
  swPart.CreateLine2 X_alt, Y_alt, 0, X_neu, Y_neu, 0
  X_alt = X_neu
Loop

'Parabel schließen x neu und x start müssen sich vom vorzeichen unterscheiden)
If Abs(X_neu + XStart) < 0.0001 Then
 swPart.CreateLine2 XStart, XStart ^ 2, 0, X_neu, X_neu ^ 2, 0
Else
 If XStart ^ 2 > X_neu ^ 2 Then
  swPart.CreateLine2 XStart, XStart ^ 2, 0, X_neu, XStart ^ 2, 0
  swPart.CreateLine2 X_neu, XStart ^ 2, 0, X_neu, Y_neu, 0
 Else
  swPart.CreateLine2 XStart, XStart ^ 2, 0, XStart, X_neu ^ 2, 0
  swPart.CreateLine2 XStart, X_neu ^ 2, 0, X_neu, X_neu ^ 2, 0
 End If
End If
'Mittellinie
swPart.CreateLine2(XStart, XStart ^ 2, 0, XStart, -Y_neu, 0).ConstructionGeometry = True

'Einstellungen wieder zurücksetzen
swPart.ViewZoomtofit2
swApp.SetUserPreferenceToggle swSketchAutomaticRelations, True

End Sub