Hello,
I am running a macros code (please find attached) in which I am creating few sketch patterns and bodies. After the macros runs, I need to be able to "play" with the created bodies: delete some of them, combine some of them, and re-pattern on the sketch (which are just dots at selected XYZ coordinates). Ideally it would be part of the macros script. However, for now I would just like to know why I am not able to select or use the sketch-patterns from the design tree and how I can solve it.
Please find attached the TXT files to run this code.
I would also like do credit @Ivana Kolin for the help with this script.
(The script is a bit long but uses 3 functions that are the same except for calling different TXT files)
Option Explicit
Dim boolstatus As Boolean
Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swPartDoc As SldWorks.PartDoc
Dim swSketchMgr As SldWorks.SketchManager
Const pathName As String = "G:\My Drive\CALCE\Matlab\BugCheking\bugCheck\"
Public Sub main()
Dim vSkLines As Variant
Dim myDisplayDim As SldWorks.DisplayDimension
Dim myFeature As SldWorks.Feature
Dim skPoint As SldWorks.SketchPoint
Dim X As Double
Dim Y As Double
Dim Z As Double
Dim L As Double
Dim H As Double
Dim B As Double
On Error GoTo main_Error
Set swApp = Application.SldWorks
Set swModelDoc = swApp.ActiveDoc
If swModelDoc Is Nothing Then
MsgBox "Open part"
Exit Sub
End If
If swModelDoc.GetType <> swDocPART Then
MsgBox "Open part"
Exit Sub
End If
Dim InputDimValOnCreate As Boolean
'Suppress the dimension dialog box
InputDimValOnCreate = swApp.GetUserPreferenceToggle(swUserPreferenceToggle_e.swInputDimValOnCreate)
swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swInputDimValOnCreate, False
Set swPartDoc = swModelDoc
Open pathName & "JointSpace.txt" For Input As #4
Input #4, L, H, B
boolstatus = swModelDoc.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
Set swSketchMgr = swPartDoc.SketchManager
swSketchMgr.AddToDB = True
swSketchMgr.DisplayWhenAdded = False
swSketchMgr.InsertSketch True
swModelDoc.ClearSelection2 True
vSkLines = swSketchMgr.CreateCornerRectangle(0, 0, 0, 5.25175614406384E-02, 4.50560499791269E-02, 0)
swModelDoc.ClearSelection2 True
boolstatus = swModelDoc.Extension.SelectByID2("Line3", "SKETCHSEGMENT", 0.02152359075436, 4.47690687690688E-02, 0, False, 0, Nothing, 0)
Set myDisplayDim = swModelDoc.AddDimension2(2.12366095443018E-02, 5.73962420116266E-02, 0)
swModelDoc.ClearSelection2 True
'Set myDimension = swModelDoc.Parameter("D1@Sketch1")
'myDimension.SystemValue = L
swModelDoc.Parameter("D1@Sketch1").SystemValue = L
boolstatus = swModelDoc.Extension.SelectByID2("Line4", "SKETCHSEGMENT", 0.120655737704918, 6.81967213114754E-02, 0, False, 0, Nothing, 0)
Set myDisplayDim = swModelDoc.AddDimension2(0.162622950819672, 7.40983606557377E-02, 0)
boolstatus = swModelDoc.Extension.SelectByID2("D1@Sketch1@swModelDoc11.SLDPRT", "DIMENSION", 0, 0, 0, False, 0, Nothing, 0)
swModelDoc.ClearSelection2 True
'Set myDimension = swModelDoc.Parameter("D2@Sketch1")
'myDimension.SystemValue = H
swModelDoc.Parameter("D2@Sketch1").SystemValue = H
swModelDoc.ClearSelection2 True
swModelDoc.ShowNamedView2 "*Trimetric", 8
swModelDoc.ClearSelection2 True
Set myFeature = swModelDoc.FeatureManager.FeatureExtrusion2(True, False, False, 0, 0, B, 0.01, False, False, False, False, 1.74532925199433E-02, 1.74532925199433E-02, False, False, False, False, True, True, True, 0, 0, False)
swModelDoc.SelectionManager.EnableContourSelection = False
swModelDoc.ClearSelection2 True
'myDimension.SystemValue = 0.015
Close #4
'D1@Boss-Extrude1
Open pathName & "Particle_1_Coordinates.txt" For Input As #1
swSketchMgr.Insert3DSketch True
Do While Not EOF(1)
Input #1, X, Y, Z
Set skPoint = swSketchMgr.CreatePoint(X, Y, Z)
Loop
Close #1
Call AddSpheres(X, Y, Z)
Open pathName & "Particle_2_Coordinates.txt" For Input As #2
swSketchMgr.Insert3DSketch True
Do While Not EOF(2)
Input #2, X, Y, Z
Set skPoint = swSketchMgr.CreatePoint(X, Y, Z)
Loop
Close #2
Call AddSpheres2(X, Y, Z)
Open pathName & "Particle_3_Coordinates.txt" For Input As #3
swSketchMgr.Insert3DSketch True
Do While Not EOF(3)
Input #3, X, Y, Z
Set skPoint = swSketchMgr.CreatePoint(X, Y, Z)
Loop
Close #3
Call AddSpheres3(X, Y, Z)
swModelDoc.ShowNamedView2 "*Isometric", 7
swModelDoc.ViewZoomtofit2
main_Exit:
On Error Resume Next
If Not swSketchMgr Is Nothing Then
swSketchMgr.AddToDB = False
swSketchMgr.DisplayWhenAdded = False
End If
swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swInputDimValOnCreate, InputDimValOnCreate
Exit Sub
main_Error:
MsgBox "Error: " & Err.Number & " (" & Err.Description & ")"
GoTo main_Exit
End Sub
Private Sub AddSpheres(X As Double, Y As Double, Z As Double)
Dim swFeat As SldWorks.Feature
Dim swFeatMgr As SldWorks.FeatureManager
Dim skSegment As SldWorks.SketchSegment
Dim bStatus As Boolean
Dim D As Double
If Not swSketchMgr.ActiveSketch Is Nothing Then
swSketchMgr.InsertSketch True
End If
Open pathName & "Particle_1_Size.txt" For Input As #4
Input #4, D
Set swFeatMgr = swModelDoc.FeatureManager
'Select "Front" plane
bStatus = swModelDoc.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
'Insert new sketch
swSketchMgr.InsertSketch True
'Create arc
Set skSegment = swSketchMgr.CreateArc(0, 0, 0, 0, D, 0, 0, -D, 0, -1)
'Add vertical line
Set skSegment = swSketchMgr.CreateLine(0, D, 0, 0, -D, 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(-D, 0, 0)
'Exit sketch
swSketchMgr.InsertSketch True
'Add Revolve feature
bStatus = swModelDoc.Extension.SelectByID2("Sketch2", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
bStatus = swModelDoc.Extension.SelectByID2("Line1@Sketch2", "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)
Close #4
End Sub
Private Sub AddSpheres2(X As Double, Y As Double, Z As Double)
Dim swFeat As SldWorks.Feature
Dim swFeatMgr As SldWorks.FeatureManager
Dim skSegment As SldWorks.SketchSegment
Dim bStatus As Boolean
Dim D As Double
If Not swSketchMgr.ActiveSketch Is Nothing Then
swSketchMgr.InsertSketch True
End If
Open pathName & "Particle_2_Size.txt" For Input As #4
Input #4, D
Set swFeatMgr = swModelDoc.FeatureManager
'Select "Front" plane
bStatus = swModelDoc.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
'Insert new sketch
swSketchMgr.InsertSketch True
'Create arc
Set skSegment = swSketchMgr.CreateArc(0, 0, 0, 0, D, 0, 0, -D, 0, -1)
'Add vertical line
Set skSegment = swSketchMgr.CreateLine(0, D, 0, 0, -D, 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(-D, 0, 0)
'Exit sketch
swSketchMgr.InsertSketch True
'Add Revolve feature
bStatus = swModelDoc.Extension.SelectByID2("Sketch3", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
bStatus = swModelDoc.Extension.SelectByID2("Line1@Sketch3", "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("Revolve2", "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/Copy2", "SOLIDBODY", 0, 0, 0, True, 256, Nothing, 0)
bStatus = swModelDoc.Extension.SelectByID2("3DSketch2", "SKETCH", 0, 0, 0, True, 64, Nothing, 0)
'Pattern the body
Set swFeat = swFeatMgr.FeatureSketchDrivenPattern(True, False)
Close #4
End Sub
Private Sub AddSpheres3(X As Double, Y As Double, Z As Double)
Dim swFeat As SldWorks.Feature
Dim swFeatMgr As SldWorks.FeatureManager
Dim skSegment As SldWorks.SketchSegment
Dim bStatus As Boolean
Dim D As Double
If Not swSketchMgr.ActiveSketch Is Nothing Then
swSketchMgr.InsertSketch True
End If
Open pathName & "Particle_3_Size.txt" For Input As #4
Input #4, D
Set swFeatMgr = swModelDoc.FeatureManager
'Select "Front" plane
bStatus = swModelDoc.Extension.SelectByID2("Front Plane", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
'Insert new sketch
swSketchMgr.InsertSketch True
'Create arc
Set skSegment = swSketchMgr.CreateArc(0, 0, 0, 0, D, 0, 0, -D, 0, -1)
'Add vertical line
Set skSegment = swSketchMgr.CreateLine(0, D, 0, 0, -D, 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(-D, 0, 0)
'Exit sketch
swSketchMgr.InsertSketch True
'Add Revolve feature
bStatus = swModelDoc.Extension.SelectByID2("Sketch4", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
bStatus = swModelDoc.Extension.SelectByID2("Line1@Sketch4", "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("Revolve3", "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/Copy3", "SOLIDBODY", 0, 0, 0, True, 256, Nothing, 0)
bStatus = swModelDoc.Extension.SelectByID2("3DSketch3", "SKETCH", 0, 0, 0, True, 64, Nothing, 0)
'Pattern the body
Set swFeat = swFeatMgr.FeatureSketchDrivenPattern(True, False)
Close #4
End Sub
