Hi.

I am attempting to write a macro to rename all sketches in a part in order (to sooth my OCD ).

The code below works for the most part. (I'm sure it is quite sloppy, feel free to suggest improvements)

The problem I am having is that some sketches (ones that belong to Extruded Cuts etc) seem to be both features and subfeatures and are being renamed twice.

I can't think of a way to prevent this. Could someone please offer a suggestion.

I have also included a sample part.

Regards Matt

Sub main()

    Set swApp = Application.SldWorks

    Set swPart = swApp.ActiveDoc

    Set swFeat = swPart.FirstFeature

    SketchCount = 1

    Do While Not swFeat Is Nothing

        newSketchName = "Sketch" & SketchCount

            If swFeat.GetTypeName2 = "ProfileFeature" Then

                If swPart.Extension.SelectByID2(newSketchName, "SKETCH", 0, 0, 0, False, 0, Nothing, 0) = True Then

                    Set tempFeat = swPart.FeatureByName(newSketchName)

                    tempFeat.Name = tempFeat.Name & "temp"

                End If

            swFeat.Name = newSketchName

            SketchCount = SketchCount + 1

            Else

                Set swsubFeat = swFeat.GetFirstSubFeature

                Do While Not swsubFeat Is Nothing

                newSketchName = "Sketch" & SketchCount

                If swsubFeat.GetTypeName2 = "ProfileFeature" Then

                    If swPart.Extension.SelectByID2(newSketchName, "SKETCH", 0, 0, 0, False, 0, Nothing, 0) = True Then

                    Set tempFeat = swPart.FeatureByName(newSketchName)

                    tempFeat.Name = tempFeat.Name & "temp"

                    End If

                swsubFeat.Name = newSketchName

                SketchCount = SketchCount + 1

                End If

                Set swsubFeat = swsubFeat.GetNextSubFeature

                Loop

            End If

            Set swFeat = swFeat.GetNextFeature

    Loop

End Sub