AnsweredAssumed Answered

Importing polydisperse spheres using a macro

Question asked by Matt Nixon on Aug 14, 2013
Latest reply on Dec 21, 2015 by Josh Brady

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

Outcomes