3 Replies Latest reply on Dec 21, 2015 5:31 PM by Josh Brady

    Importing polydisperse spheres using a macro

    Matt Nixon

      Hi,

       

      I've previously been importing spheres (all with the same diameter) into solidworks using a macro, as a result of the discussion here: https://forum.solidworks.com/message/356730#356730

       

      I've tried to edit this script to allow me to import polysdisperse spheres (i.e. inputting the x,y,z locations and diameters from a text file), but I can't figure out what I have done wrong. If anybody could point this out, I would be very gratefull!

       

      The macro script is here:

       

      Option Explicit

          Dim swApp As SldWorks.SldWorks

          Dim swModelDoc As SldWorks.ModelDoc2

         

      Sub main()

          Dim skPoint As SldWorks.SketchPoint

          Dim X As Double, Y As Double, Z As Double, dblRadius As Double

         Const dblMulti As Double = 10

         

          Set swApp = Application.SldWorks

          Set swModelDoc = swApp.ActiveDoc

          swModelDoc.ViewZoomTo2 0, 0, 0, 0.0000001, 0.0000001, 0.0000001

          

          Open "D:\Spiloxene\Poly-MRJ modelling\July\04 k=1e-3 size=10 var=0.2()\xyzd.txt" For Input As #1

          swModelDoc.SketchManager.Insert3DSketch True

          Do While Not EOF(1)

              Input #1, X, Y, Z, dblRadius

              Set skPoint = swModelDoc.SketchManager.CreatePoint(X * dblMulti, Y * dblMulti, Z * dblMulti)

          Loop

        

      'Close and hide 3D sketch

          swModelDoc.SketchManager.InsertSketch True

          swModelDoc.BlankSketch

         

          Close #1

         

          Call AddSpheres(X, Y, Z, dblRadius)

          

          swModelDoc.ShowNamedView2 "*Isometric", 7

          swModelDoc.ViewZoomtofit2

      End Sub

      Sub AddSpheres(X As Double, Y As Double, Z As Double, dblRadius As Double)

          Dim swFeat As SldWorks.Feature

          Dim swFeatMgr As SldWorks.FeatureManager

          Dim skSegment As SldWorks.SketchSegment

          Dim swDispDim As SldWorks.DisplayDimension

          Dim bStatus As Boolean

         ' Const dblRadius As Double = 0.00000032 'Radius of sphere in meters

          Set swFeatMgr = swModelDoc.FeatureManager

         

      'Select "Front" plane

          bStatus = swModelDoc.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, _

              False, 0, Nothing, 0)

      'Insert new sketch

          swModelDoc.SketchManager.InsertSketch True

         

      'Create arc

          Set skSegment = swModelDoc.SketchManager.CreateArc(0, 0, 0, 0, dblRadius, 0, _

              0, -dblRadius, 0, -1)

      'Add vertical line

          Set skSegment = swModelDoc.SketchManager.CreateLine(0, dblRadius, 0, _

              0, -dblRadius, 0)

      'Add arc center point to current selection

          bStatus = swModelDoc.Extension.SelectByID2("", "SKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)

      'Add "Midpoint" relation between arc center point and vertical center line

          swModelDoc.SketchAddConstraints "sgATMIDDLE"

         

      'Clear selections

          swModelDoc.ClearSelection2 True

      'Select vertical line

          bStatus = swModelDoc.Extension.SelectByID2("Line1", "SKETCHSEGMENT", 0, 0, 0, _

              True, 0, Nothing, 0)

      'Add dimension

      '    Set swDispDim = swModelDoc.AddDimension2(-dblRadius, 0, 0)

      'Exit sketch

          swModelDoc.InsertSketch2 True

      'Add Revolve feature

          bStatus = swModelDoc.Extension.SelectByID2("Sketch1", "SKETCH", 0, 0, 0, _

              False, 0, Nothing, 0)

          bStatus = swModelDoc.Extension.SelectByID2("Line1@Sketch1", "SKETCHSEGMENT", _

              0, 0, 0, True, 4, Nothing, 0)

          Set swFeat = swModelDoc.FeatureManager.FeatureRevolve2(True, True, False, False, False, _

              False, 0, 0, 6.28318530718, 0, False, False, 0.01, 0.01, 0, 0, 0, False, True, True)

       

      'Clear selections

          swModelDoc.ClearSelection2 True

      'Get the body

          bStatus = swModelDoc.Extension.SelectByID2("Revolve1", "SOLIDBODY", 0, 0, 0, _

              True, 1, Nothing, 0)

      'Move the body to the first point

          Set swFeat = swFeatMgr.InsertMoveCopyBody2(X, Y, Z, 0, 0, 0, 0, 0, 0, 0, False, 1)

      'Clear selections

          swModelDoc.ClearSelection2 True

      'Get the body and 3D sketch

          bStatus = swModelDoc.Extension.SelectByID2("Body-Move/Copy1", "SOLIDBODY", 0, 0, 0, _

              True, 256, Nothing, 0)

          bStatus = swModelDoc.Extension.SelectByID2("3DSketch1", "SKETCH", 0, 0, 0, _

              True, 64, Nothing, 0)

      'Pattern the body

          Set swFeat = swFeatMgr.FeatureSketchDrivenPattern(True, False)

      End Sub

        • Re: Importing polydisperse spheres using a macro
          Jacob Keilman

          I was facing the same issue (needing to import polydisperse spheres into SW), and developed the following solution by building on the original macro for monodisperse spheres. This method is much slower, as each sphere has to be sketched and revolved individually, rather than using a feature pattern, but I don't see a way around this issue. If anyone knows of a faster/better way to do this, I'd love to hear it!

           

          Option Explicit

              Dim swApp As SldWorks.SldWorks

              Dim swModelDoc As SldWorks.ModelDoc2

            

          Sub main()

              Dim skPoint As SldWorks.SketchPoint

              Dim X As Double, Y As Double, Z As Double

              Dim Radius As Double

              Dim LineFromFile As String

              Dim lineItems() As String

              Dim sphereNumber As Integer

              Const filePath As String = "D:\Google Drive\Research\Code\SWinput.txt"

            

              Set swApp = Application.SldWorks

              Set swModelDoc = swApp.ActiveDoc

             

              'Open File

              Open filePath For Input As #1

              swModelDoc.SketchManager.Insert3DSketch True

             

              'Intialize counter for spheres

              sphereNumber = 1

             

              'Read File line by line

              Do Until EOF(1)

                  Line Input #1, LineFromFile

                  lineItems = Split(LineFromFile, ",")

                  X = lineItems(0)

                  Y = lineItems(1)

                  Z = lineItems(2)

                  Radius = Val(lineItems(3))

           

           

                  'Create sphere for current point

                  Call CreateSphere(X, Y, Z, Radius, sphereNumber)

                  sphereNumber = sphereNumber + 1

              Loop

           

              'Close File

              Close #1

             

              'Move view to show structure

              swModelDoc.ShowNamedView2 "*Isometric", 7

              swModelDoc.ViewZoomtofit2

          End Sub

           

           

          Sub CreateSphere(X As Double, Y As Double, Z As Double, Radius As Double, sphereNumber As Integer)

           

           

          Dim swFeat As SldWorks.Feature

              Dim swFeatMgr As SldWorks.FeatureManager

              Dim skSegment As SldWorks.SketchSegment

              Dim swDispDim As SldWorks.DisplayDimension

              Dim bStatus As Boolean

              Dim CurSketch As String, CurRevolve As String

             

              Set swFeatMgr = swModelDoc.FeatureManager

            

          'Select "Front" plane

              bStatus = swModelDoc.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, _

                  False, 0, Nothing, 0)

          'Insert new sketch

              swModelDoc.SketchManager.InsertSketch True

          'Create arc

              Set skSegment = swModelDoc.SketchManager.CreateArc(0, 0, 0, 0, Radius, 0, _

                  0, -Radius, 0, -1)

          'Add vertical line

              Set skSegment = swModelDoc.SketchManager.CreateLine(0, Radius, 0, _

                  0, -Radius, 0)

          'Add arc center point to current selection

              bStatus = swModelDoc.Extension.SelectByID2("", "SKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)

          'Add "Midpoint" relation between arc center point and vertical center line

              swModelDoc.SketchAddConstraints "sgATMIDDLE"

          'Clear selections

              swModelDoc.ClearSelection2 True

          'Select vertical line

              bStatus = swModelDoc.Extension.SelectByID2("Line1", "SKETCHSEGMENT", 0, 0, 0, _

                  True, 0, Nothing, 0)

          'Exit sketch

              swModelDoc.InsertSketch2 True

          'Add Revolve feature

              CurSketch = "Sketch" & Trim(Str(sphereNumber)) 'Generate current sketch name

              bStatus = swModelDoc.Extension.SelectByID2(CurSketch, "SKETCH", 0, 0, 0, _

                  False, 0, Nothing, 0)

              bStatus = swModelDoc.Extension.SelectByID2("Line1@" & CurSketch, "SKETCHSEGMENT", _

                  0, 0, 0, True, 4, Nothing, 0)

              Set swFeat = swModelDoc.FeatureManager.FeatureRevolve2(True, True, False, False, False, _

                  False, 0, 0, 6.28318530718, 0, False, False, 0.01, 0.01, 0, 0, 0, False, True, True)

          'Clear selections

              swModelDoc.ClearSelection2 True

          'Get the body

              CurRevolve = "Revolve" & Trim(Str(sphereNumber)) 'Generate current revolve name

              bStatus = swModelDoc.Extension.SelectByID2(CurRevolve, "SOLIDBODY", 0, 0, 0, _

                  True, 1, Nothing, 0)

          'Move the body to the current point

              Set swFeat = swFeatMgr.InsertMoveCopyBody2(X, Y, Z, 0, 0, 0, 0, 0, 0, 0, False, 1)

          'Clear selections

              swModelDoc.ClearSelection2 True

           

           

          End Sub

            • Re: Importing polydisperse spheres using a macro
              Josh Brady

              As long as you don't need to edit the resulting spheres/locations, you may want to look into using the Modeler interface to directly create the spheres without sketches etc.  It would probably be considerably faster.

               

              2015 SOLIDWORKS API Help - ICreateSphericalSurface2 Method (IModeler)

              • Re: Importing polydisperse spheres using a macro
                Josh Brady

                This macro creates random-sized spheres at random locations within a cube.

                 

                On my computer, 100 spheres takes 13 seconds, 200 spheres takes 32 seconds, 300 spheres takes 62 seconds.  Give or take.

                 

                Option Explicit
                
                Const SphereMax As Double = 0.05 '(50mm)
                Const BoxSize As Double = 1 ' (1m)
                Const NumSpheres As Long = 100
                
                
                
                Sub main()
                
                    Dim swApp As SldWorks.SldWorks
                    Dim swDoc As ModelDoc2
                    Dim swBody As Body2
                    Dim swPart As PartDoc
                    Dim swModeler As Modeler
                    Dim swFeat As Feature
                
                    Set swApp = Application.SldWorks
                    Set swDoc = swApp.ActiveDoc
                    Set swPart = swDoc
                    Set swModeler = swApp.GetModeler
                
                    Dim swSurf As Surface
                    Dim swSurfPara As SldWorks.SurfaceParameterizationData
                    Dim Arr3Doubles(3) As Double
                    Dim UVRange(3) As Double
                    Dim vCenter As Variant
                    Dim vAxis As Variant
                    Dim vRefDir As Variant
                    Dim i As Long
                    Dim StopWatch As Double
                    
                
                    Randomize
                
                    If MsgBox("About to create " & NumSpheres & " spheres.  Continue?", vbYesNo) = vbNo Then Exit Sub
                    
                    StopWatch = Timer
                
                    For i = 1 To NumSpheres
                        Arr3Doubles(0) = RC(BoxSize): Arr3Doubles(1) = RC(BoxSize): Arr3Doubles(2) = RC(BoxSize)
                        vCenter = Arr3Doubles
                        Arr3Doubles(0) = 0: Arr3Doubles(1) = 0: Arr3Doubles(2) = 1
                        vAxis = Arr3Doubles
                        Arr3Doubles(0) = 0: Arr3Doubles(1) = 1: Arr3Doubles(2) = 0
                        vRefDir = Arr3Doubles
                        
                        Set swSurf = swModeler.CreateSphericalSurface2(vCenter, vAxis, vRefDir, RC(SphereMax))
                    
                        Set swSurfPara = swSurf.Parameterization2
                    
                        UVRange(0) = swSurfPara.UMin
                        UVRange(1) = swSurfPara.UMax
                        UVRange(2) = swSurfPara.VMin
                        UVRange(3) = swSurfPara.VMax
                    
                        Set swBody = swModeler.CreateSheetFromSurface(swSurf, UVRange)
                    
                        Set swFeat = swPart.CreateFeatureFromBody3(swBody, False, swCreateFeatureBodyCheck + swCreateFeatureBodySimplify)
                    
                        swFeat.Name = "Sphere_" & i
                    Next i
                
                    MsgBox "Finished in " & Round(Timer - StopWatch, 2) & " seconds."
                
                End Sub
                
                Function RC(ByVal MyMax As Double)
                RC = MyMax * Rnd
                End Function