Mass unselect of "Mark for Drawing"
Mass unselect of "Mark for Drawing"
(OP)
I am looking for a way to unselect all dimensions that are selected as "Mark for Drawing". I only need about a dozen dimension for my automated print, but part of the automated print generation is the importing of model items. Since I use a lot of weldments, all of the dimensions for the profiles are coming in as well as some other non-critical dimensions.
I guess I need a macro that cycles through all sketches in a model, if I had that, I could probably add my portion to it. I can then go back an manually add the ones that I want (far fewer than doing it the other way!).
Thanks!
Joe
I guess I need a macro that cycles through all sketches in a model, if I had that, I could probably add my portion to it. I can then go back an manually add the ones that I want (far fewer than doing it the other way!).
Thanks!
Joe






RE: Mass unselect of "Mark for Drawing"
CODE
Dim part As SldWorks.ModelDoc2
Dim boolstatus As Boolean
Dim longstatus As Long
Dim Annotation As Object
Dim Gtol As Object
Dim DatumTag As Object
Dim FeatureData As Object
Dim myFeature As SldWorks.Feature
Dim Component As Object
Dim Body As Object
Dim Face As Object
Dim bStatus As Boolean
Dim iCount As Integer
Dim sFeatName As String
Dim iNumFeat As Long
Sub main()
Set swApp = CreateObject("SldWorks.Application")
Set part = swApp.ActiveDoc
iNumFeat = part.GetFeatureCount
Set myFeature = part.FirstFeature
For iCount = 1 To iNumFeat
If Not myFeature.IsSuppressed Then
If myFeature.GetTypeName = "ProfileFeature" Then
myFeature.Select False
part.InsertSketch2 True
Call FixThePoints(myFeature.GetSpecificFeature2, part)
part.EditRebuild3
End If
End If
Set myFeature = myFeature.GetNextFeature
Next iCount
part.ClearSelection
End Sub
Sub FixThePoints(mySketch As SldWorks.Sketch, part As SldWorks.ModelDoc2)
Dim MyPointArray As Variant
Dim myPoint As SldWorks.SketchPoint
Dim myRelMgr As SldWorks.SketchRelationManager
Dim dummyRel As SldWorks.SketchRelation
Dim mySelMgr As SldWorks.SelectionMgr
Dim mySketchSegArray As Variant
Dim mySeg As SketchSegment
Dim myArc As SketchArc
Dim i As Long
'First we fix all the sketch points
MyPointArray = mySketch.GetSketchPoints
mySketchSegArray = mySketch.GetSketchSegments
Set myRelMgr = mySketch.RelationManager
Set mySelMgr = part.SelectionManager
part.ClearSelection
If Not IsEmpty(MyPointArray) Then
For i = 0 To UBound(MyPointArray)
Set myPoint = MyPointArray(i)
myPoint.Select True
Next i
End If
part.SketchAddConstraints "sgFIXED"
'Any partial arc will already be fixed by its center point
'and its end points. Circles, however, only have one point.
'Therefore we fix all complete circles
part.ClearSelection
If Not IsEmpty(mySketchSegArray) Then
For i = 0 To UBound(mySketchSegArray)
Set mySeg = mySketchSegArray(i)
If mySeg.GetType = swSketchARC Then
Set myArc = mySeg
If myArc.IsCircle = 1 Then 'Test whether it is complete circle
mySeg.Select True
End If
End If
Next i
End If
part.SketchAddConstraints "sgFIXED"
End Sub
RE: Mass unselect of "Mark for Drawing"
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim swSubFeat As SldWorks.Feature
Dim swDispDim As SldWorks.DisplayDimension
Dim swDim As SldWorks.Dimension
Dim swAnn As SldWorks.Annotation
Dim bRet As Boolean
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
Set swFeat = swModel.FirstFeature
Debug.Print "File = " & swModel.GetPathName
Do While Not swFeat Is Nothing
Debug.Print " " + swFeat.Name
Set swSubFeat = swFeat.GetFirstSubFeature
Do While Not swSubFeat Is Nothing
Debug.Print " " + swSubFeat.Name
Set swDispDim = swSubFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Set swDim = swDispDim.GetDimension
Debug.Print " [" & swDim.FullName & "] = " & swDim.GetSystemValue2("")
Set swDispDim = swSubFeat.GetNextDisplayDimension(swDispDim)
Loop
Set swSubFeat = swSubFeat.GetNextSubFeature
Loop
Set swDispDim = swFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
Set swDim = swDispDim.GetDimension
swDispDim.MarkedForDrawing = False
Debug.Print " [" & swDim.FullName & "] = " & swDim.GetSystemValue2("")
Debug.Print " Marked For Drawing =" & swDispDim.MarkedForDrawing
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
Loop
Set swFeat = swFeat.GetNextFeature
Loop
End Sub