OT(sorta'!) - Anyone know how I might approach this...

You can find the C source code from Eric Haines in the Standard Procedural Databases at

balls.c -> May be you can port it to SW,

Pascal

"Mike Tripoli" a écrit dans le message de news: snipped-for-privacy@4ax.com...

Hi, Yes, I have this info (I even looked at compiling it... nope)... Not a programmer, wouldn't know where to start witht his...

MT

That appears to be similar to Paul's Star benchmark. Perhaps you could alter that creaate spheres instead of boxes.

Where might one find this benchmark? Thanks!

Mike Tripoli

Search the Performance discussion group on the subscription site for STAR

2.0. There is a zip file attached to the first message that contains the macro.

Its the STAR benchmark in 3D. It is done by recursion. I have a version that does cylinders. The next step would be to take it to spheres in 3D.

Mike,

Here is the Charlie Brown version. Or you could call it BoxFlake. When rendered in PhotoWorks some interesting effects happen.

Do me a favor. I rewrote this on 2005. If someone is running 2003, 2004 or other release, let me know if it works right. Also be aware that you will have to set your type library to whatever release you are running on. And also let me know what time you get for level 5.

' ****************************************************************************** ' BoxTree.swb - macro recorded on 6/1/05 by kellnerp ' ' VERSION UPDATED BY REMARKS ' 0.0 6/1/05 PBK MODIFIED FROM STAR2.1 ' ' Make sure to check TOOL/REFERENCES Solidworksnnnn Type Library appropriate to your version ' of SolidWorks. ' ' ******************************************************************************

'Force variable declaration to speed execution per Frank Option Explicit

Const TitleStr As String = "BENCHMARK BOXTREE" Const Rfact As Double = 1 / 3

Dim swApp As SldWorks.SldWorks Dim Part As SldWorks.ModelDoc2 Dim swPartExtension As SldWorks.ModelDocExtension Dim swSelMgr As SldWorks.SelectionMgr Dim Feature As SldWorks.Feature

Dim swFeatMgr As Object Dim boolstatus As Boolean Dim longstatus As Long, longwarnings As Long

Dim PathName As String Dim PartName As String Dim r As Double Dim n As Long Dim OldPrefs(12) As Boolean Dim StartTime, IntTime, EndTime As Long Dim TotalTime, RTime As Double

Sub main()

Set swApp = Application.SldWorks Set Part = swApp.NewPart

'Frank's suggestions to reduce system dependence

Set swPartExtension = Part.Extension Set swFeatMgr = Part.FeatureManager Set swSelMgr = Part.SelectionManager

'Where does the user want the part saved? Call MsgPathName(PathName) boolstatus = swApp.SetCurrentWorkingDirectory(PathName)

'How many levels does the user want to run? n = MsgLevels() r = 2 ^ (n - 1)

Randomize PartName = "Part" & Format(1000 * Rnd()) Set Part = swApp.ActivateDoc2(PartName, False, longstatus)

Set Part = swApp.ActiveDoc

'Set some preferences and save old ones Call SetPrefs(Part, swApp)

Select Case CheckRelease()

Case 11

Part.SetAddToDB True Part.SetDisplayWhenAdded (False)

'Set the starting time. StartTime = Timer()

Call star(0, 0, 0, r)

'Set Intermediate time IntTime = Timer()

boolstatus = Part.ForceRebuild3(False)

'Set the ending time. EndTime = Timer()

Part.SetAddToDB False Part.SetDisplayWhenAdded (True)

Case 12

Part.SetAddToDB True Part.SetDisplayWhenAdded (False)

'Set the starting time. StartTime = Timer()

Call star(0, 0, 0, r)

'Set Intermediate time IntTime = Timer()

boolstatus = Part.ForceRebuild3(False)

'Set the ending time. EndTime = Timer()

Part.SetAddToDB True Part.SetDisplayWhenAdded (True)

Case 13

Part.SetAddToDB True Part.SetDisplayWhenAdded (False)

'Set the starting time. StartTime = Timer()

Call star2(0, 0, 0, r)

'Set Intermediate time IntTime = Timer()

boolstatus = Part.ForceRebuild3(False)

'Set the ending time. EndTime = Timer()

Part.SetAddToDB False Part.SetDisplayWhenAdded (True)

Case 14

Part.SetAddToDB True Part.SetDisplayWhenAdded (False)

'Set the starting time. StartTime = Timer()

Call star3(0, 0, r)

'Set Intermediate time IntTime = Timer()

boolstatus = Part.ForceRebuild3(False)

'Set the ending time. EndTime = Timer()

Part.SetAddToDB False Part.SetDisplayWhenAdded (True)

Case Else

Exit Sub

End Select

TotalTime = CDbl(DateDiff("s", StartTime, EndTime)) / 100000# RTime = CDbl(DateDiff("s", IntTime, EndTime)) / 100000#

Part.ShowNamedView2 "*Trimetric", 8 Part.ClearSelection2 True Part.ViewZoomtofit2

Call SavePart(PathName, PartName, RTime, TotalTime, n)

'Be nice and put things back the way they were

Call RestorePrefs(swApp)

End Sub

Sub star(x As Double, y As Double, z As Double, r As Double)

If r >= Rfact Then Call star(x - r, y + r, z + r, r * Rfact) Call star(x + r, y + r, z + r, r * Rfact) Call star(x - r, y - r, z - r, r * Rfact) Call star(x + r, y - r, z - r, r * Rfact) Call star(x - r, y + r, z - r, r * Rfact) Call star(x + r, y + r, z - r, r * Rfact) Call star(x - r, y - r, z + r, r * Rfact) Call star(x + r, y - r, z + r, r * Rfact) Call box(x, y, z, r) End If

End Sub Sub star2(x As Double, y As Double, z As Double, r As Double)

If r >= Rfact Then Call star2(x - r, y + r, z + r, r * Rfact) Call star2(x + r, y + r, z + r, r * Rfact) Call star2(x - r, y - r, z - r, r * Rfact) Call star2(x + r, y - r, z - r, r * Rfact) Call star2(x - r, y + r, z - r, r * Rfact) Call star2(x + r, y + r, z - r, r * Rfact) Call star2(x - r, y - r, z + r, r * Rfact) Call star2(x + r, y - r, z + r, r * Rfact) Call box2(x, y, z, r) End If

End Sub

Sub star3(x As Double, y As Double, r As Double)

If r >= Rfact Then Call star3(x - r, y + r, z + r, r * Rfact) Call star3(x + r, y + r, z + r, r * Rfact) Call star3(x - r, y - r, z - r, r * Rfact) Call star3(x + r, y - r, z - r, r * Rfact) Call star3(x - r, y + r, z - r, r * Rfact) Call star3(x + r, y + r, z - r, r * Rfact) Call star3(x - r, y - r, z + r, r * Rfact) Call star3(x + r, y - r, z + r, r * Rfact) Call box3(x, y, z, r) End If

End Sub

Sub box(x As Double, y As Double, z As Double, r As Double)

' For 2004 compatibility boolstatus = swPartExtension.SelectByID("Top", "PLANE", 0, 0, 0, False, 0, Nothing) If z >= 0 Then Set Feature = Part.CreatePlaneAtOffset3(z, False, True) Else Set Feature = Part.CreatePlaneAtOffset3(Abs(z), True, True) End If

Part.ClearSelection2 True boolstatus = Feature.Select2(False, 0): Debug.Assert boolstatus Part.InsertSketch2 True Part.ClearSelection2 True Part.SketchRectangle x - r, y - r, 0, x + r, y + r, 0, 1 Part.ClearSelection2 True

'For 2004 Compatibility boolstatus = swPartExtension.SelectByID("Line2", "SKETCHSEGMENT",

0, 0, 0, False, 0, Nothing) boolstatus = swPartExtension.SelectByID("Line1", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing) boolstatus = swPartExtension.SelectByID("Line4", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing) boolstatus = swPartExtension.SelectByID("Line3", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing)

' For 2004 compatibility swFeatMgr.FeatureExtrusion True, False, False, 6, 0, 2 * r,

0.00254, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, 1, 1, 1

swSelMgr.EnableContourSelection = 0

End Sub

Sub box2(x As Double, y As Double, z As Double, r As Double)

' For 2005 compatibility boolstatus = Part.Extension.SelectByID2("Top Plane", "PLANE", 0, 0,

0, False, 0, Nothing, 0)

If z >= 0 Then Set Feature = Part.CreatePlaneAtOffset3(z, False, True) Else Set Feature = Part.CreatePlaneAtOffset3(Abs(z), True, True) End If

Part.ClearSelection2 True boolstatus = Feature.Select2(False, 0): Debug.Assert boolstatus

Part.InsertSketch2 True

Part.ClearSelection2 True Part.SketchRectangle x - r, y - r, 0, x + r, y + r, 0, 1 Part.ClearSelection2 True

'For 2005+ Updates boolstatus = swPartExtension.SelectByID2("Line2", "SKETCHSEGMENT",

0, 0, 0, False, 0, Nothing, 0) boolstatus = swPartExtension.SelectByID2("Line1", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0) boolstatus = swPartExtension.SelectByID2("Line4", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0) boolstatus = swPartExtension.SelectByID2("Line3", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0)

' For SW2005+ updates swFeatMgr.FeatureExtrusion2 True, False, False, 6, 0, 2 * r,

0.00254, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, 1, 1, 1, 0, 0, False

swSelMgr.EnableContourSelection = 0

End Sub

Sub box3(x As Double, y As Double, z As Double, r As Double)

boolstatus = Part.Extension.SelectByID2("Top Plane", "PLANE", 0, 0,

0, False, 0, Nothing, 0)

If z >= 0 Then Set Feature = Part.CreatePlaneAtOffset3(z, False, True) Else Set Feature = Part.CreatePlaneAtOffset3(Abs(z), True, True) End If

Part.ClearSelection2 True boolstatus = Feature.Select2(False, 0): Debug.Assert boolstatus

Part.InsertSketch2 True

Part.ClearSelection2 True Part.SketchRectangle x - r, y - r, 0, x + r, y + r, 0, 1 Part.ClearSelection2 True

boolstatus = swPartExtension.SelectByID2("Line2", "SKETCHSEGMENT",

0, 0, 0, False, 0, Nothing, 0) boolstatus = swPartExtension.SelectByID2("Line1", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0) boolstatus = swPartExtension.SelectByID2("Line4", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0) boolstatus = swPartExtension.SelectByID2("Line3", "SKETCHSEGMENT", 0, 0, 0, True, 0, Nothing, 0)

swFeatMgr.FeatureExtrusion2 True, False, False, 6, 0, 2 * r,

0.00254, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, 1, 1, 1, 0, 0, False

swSelMgr.EnableContourSelection = 0

End Sub

Sub MsgPathName(ByRef PathName As String)

Dim Message, Default Message = "Enter the fully qualified path for results ending in \" ' Set prompt. Default = "C:\" ' Set default.

' Display dialog box at position 100, 100. PathName = InputBox(Message, TitleStr, Default, 100, 100)

End Sub

Function MsgLevels() As Long

Dim Message, Default Message = "Enter the number of levels" ' Set prompt. Default = "2" ' Set default.

' Display dialog box at position 100, 100. MsgLevels = InputBox(Message, TitleStr, Default, 100, 100)

End Function

Sub SavePart(ByRef PathName As String, ByRef PartName As String, RTime, Time, r)

Dim NewName, Msg As String Dim Style As Long

NewName = PathName & PartName & ".sldprt"

If (Part.SaveAs(NewName)) Then

' Define message

Msg = "Part Saved As " + NewName + vbCrLf _ + " TIME = " + Format(Time, "##0.00") + " s" + vbCrLf _ + " LEVELS = " + Format(r, "#0") + vbCrLf _ + "REBUILD = " + Format(RTime, "##0.00") + " s"

' Button option shows OK only

Style = vbOKOnly

Call MsgBox(Msg, Style, TitleStr) ' Display message to user

End If ' End if SaveAs is successful

End Sub

Sub SetPrefs(ByRef Part As Object, ByRef swApp As Object)

'swApp.ActiveDoc.ActiveView.FrameState = swWindowMaximized swApp.ActiveDoc.ActiveView.FrameState = swWindowMinimized

OldPrefs(0) = swApp.GetUserPreferenceToggle(swEnablePerformanceEmail) OldPrefs(1) = swApp.GetUserPreferenceToggle(swEdgesDisplayShadedPlanes) OldPrefs(2) = swApp.GetUserPreferenceToggle(swPerformanceVerifyOnRebuild) OldPrefs(3) = swApp.GetUserPreferenceToggle(swUseFolderSearchRules) OldPrefs(4) = swApp.GetUserPreferenceToggle(swFeatureManagerEnsureVisible) OldPrefs(5) = swApp.GetUserPreferenceToggle(swFeatureManagerDynamicHighlight) OldPrefs(6) = swApp.GetUserPreferenceToggle(swShowErrorsEveryRebuild) OldPrefs(7) = swApp.GetUserPreferenceToggle(swUseShadedFaceHighlight) OldPrefs(8) = swApp.GetUserPreferenceToggle(swThumbnailGraphics) OldPrefs(9) = swApp.GetUserPreferenceToggle(swEnableConfirmationCorner) OldPrefs(10) = swApp.GetUserPreferenceToggle(swAutoShowPropertyManager) OldPrefs(11) = swApp.GetUserPreferenceIntegerValue(swBackupCopiesPerDocument)

swApp.SetUserPreferenceToggle swEnablePerformanceEmail, False swApp.SetUserPreferenceToggle swEdgesDisplayShadedPlanes, False swApp.SetUserPreferenceToggle swPerformanceVerifyOnRebuild, False swApp.SetUserPreferenceToggle swUseFolderSearchRules, False swApp.SetUserPreferenceToggle swFeatureManagerEnsureVisible, False swApp.SetUserPreferenceToggle swFeatureManagerDynamicHighlight, False swApp.SetUserPreferenceToggle swShowErrorsEveryRebuild, False swApp.SetUserPreferenceToggle swUseShadedFaceHighlight, False swApp.SetUserPreferenceToggle swThumbnailGraphics, False swApp.SetUserPreferenceToggle swEnableConfirmationCorner, False swApp.SetUserPreferenceToggle swAutoShowPropertyManager, False swApp.SetUserPreferenceIntegerValue swBackupCopiesPerDocument, 0

Part.SetUserPreferenceIntegerValue swImageQualityShaded, swShadedImageQualityCoarse Part.SetUserPreferenceIntegerValue swImageQualityWireframe, swWireframeImageQualityOptimal

Part.SetUserPreferenceIntegerValue swUnitsLinear, swINCHES Part.SetUserPreferenceIntegerValue swUnitsLinearDecimalDisplay, swDECIMAL Part.SetUserPreferenceIntegerValue swUnitsLinearFractionDenominator, 8 Part.SetUserPreferenceToggle swUnitsLinearRoundToNearestFraction, False Part.SetUserPreferenceToggle swGridDisplay, False Part.SetUserPreferenceIntegerValue swImageQualityWireframe, swWireframeImageQualityCustom

'Part.ViewDisplayShadedWithEdges Part.ViewDisplayShaded

End Sub

Sub RestorePrefs(ByRef swApp As Object)

swApp.SetUserPreferenceToggle swEnablePerformanceEmail, OldPrefs(0) swApp.SetUserPreferenceToggle swEdgesDisplayShadedPlanes, OldPrefs(1) swApp.SetUserPreferenceToggle swPerformanceVerifyOnRebuild, OldPrefs(2) swApp.SetUserPreferenceToggle swUseFolderSearchRules, OldPrefs(3) swApp.SetUserPreferenceToggle swFeatureManagerEnsureVisible, OldPrefs(4) swApp.SetUserPreferenceToggle swFeatureManagerDynamicHighlight, OldPrefs(5) swApp.SetUserPreferenceToggle swShowErrorsEveryRebuild, OldPrefs(6) swApp.SetUserPreferenceToggle swUseShadedFaceHighlight, OldPrefs(7) swApp.SetUserPreferenceToggle swThumbnailGraphics, OldPrefs(8) swApp.SetUserPreferenceToggle swEnableConfirmationCorner, OldPrefs(9) swApp.SetUserPreferenceToggle swAutoShowPropertyManager, OldPrefs(10) swApp.SetUserPreferenceIntegerValue swBackupCopiesPerDocument, OldPrefs(11)

swApp.ActiveDoc.ActiveView.FrameState = swWindowMaximized

End Sub

Function CheckRelease() As Long

CheckRelease = CLng(Left(swApp.RevisionNumber(), InStr(swApp.RevisionNumber(), ".")))

End Function