Mass unselect of "Mark for Drawing" 1

[JoeMoss]

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

 

[handleman]

This code will traverse the part and open all sketches related to features for editing. It will then fix all points in the sketch and rebuild, which exits the sketch editing mode. Not exactly what you're looking for, but it will traverse all sketches. You'll want to change the point fixing code to dimension un-marking code.

Dim swApp As Object
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

 

[JoeMoss]

Handleman, thanks for the help. I didn't end up using your code, but it put me on the right path. There was actually two items in API help that got to my final code: "Iterate through dimensions in model example" and "Determine if Display Dimension Marked for Drawing Example". Here is the code that will blast through the model and set all dimensions to Un-Marked 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