1 Reply Latest reply on Aug 27, 2013 2:58 PM by Feroz Mahomed

    How to get all points for sketch entities (arcs, circles and lines)

    Darren Smith

      Can anybody help?


      If you take a look at the following link it will show how to get centre points & radius for a circle




      How can I do something similar to the above but for all circles, arcs & lines in a sketch (eg without selecting the entities individually)


      Basically, I want to run a macro on a sldprt that finds all circles, arcs and lines for each sketch that I have created.


      This will only be applied to a flat 2d plate (eg a laser cut profile)


      Many thanks in advance!!!



        • Re: How to get all points for sketch entities (arcs, circles and lines)
          Feroz Mahomed



          I found this one in the forum that saves points to a txt file.



          ' Option Explicit


          Public Enum swSketchSegments_e

              swSketchLine = 0

              swSketchArc = 1

              swSketchEllipse = 2

              swSketchSpline = 3

              swSketchTEXT = 4

              swSketchParabola = 5

          End Enum


          Sub main()
              Dim swApp                           As SldWorks.SldWorks
              Dim swModel                         As SldWorks.ModelDoc2
              Dim swSelMgr                        As SldWorks.SelectionMgr
              Dim swFeat                          As SldWorks.feature
              Dim swSketch                        As SldWorks.sketch
              Dim i                               As Long
              Dim bRet                            As Boolean
              Dim vSketchSeg                      As Variant
              Dim swSketchSeg                     As SldWorks.SketchPoint
              Dim nLength                         As Double
              Dim xValue() As Double
              Dim yValue() As Double
              Dim zValue() As Double
              Dim point_count As Integer
          On Error GoTo error:

              Set swApp = CreateObject("SldWorks.Application")

               Set swModel = swApp.ActiveDoc
              If swModel.GetSaveFlag Then
                      MsgBox "Part/Assembly must be saved", vbCritical
                      Exit Sub
              End If
          If swModel Is Nothing Then Exit Sub
              Set swSelMgr = swModel.SelectionManager

              Set swFeat = swSelMgr.GetSelectedObject5(1)
          If swFeat Is Nothing Then
              Set swSketch = swModel.GetActiveSketch2
              If swSketch Is Nothing Then
                  MsgBox ("you must select the sketch from feature manager tree or at least be in a sketch")
                  Exit Sub
              End If

              Set swSketch = swFeat.GetSpecificFeature2
          End If

                  vSketchSeg = swSketch.GetSketchPoints
                  point_count = UBound(vSketchSeg)
          ReDim xValue(point_count)
          ReDim yValue(point_count)
          ReDim zValue(point_count)

              For i = 0 To point_count

                  Set swSketchSeg = vSketchSeg(i)
                  xValue(i) = swSketchSeg.x * 1000
                  yValue(i) = swSketchSeg.y * 1000
                  zValue(i) = swSketchSeg.z * 1000
              Next i

          tFilename = swModel.GetPathName
          sFilename = Left(tFilename, Len(tFilename) - 7)
          Set fs = CreateObject("Scripting.FileSystemObject")
          Set f = fs.CreateTextFile(sFilename & ".txt", True)
             For i = 0 To point_count
                      f.writeline Format(xValue(i)) & "," & _
                      Format(yValue(i)) & "," & _
             Next i
          MsgBox Left(swModel.GetTitle, Len(swModel.GetTitle) - 7) & ".txt file created under working directory"
          Exit Sub
          error:    MsgBox " please make sure that:" & vbCrLf & _
                      "1. Only one SolidWorks session is opened" & vbCrLf & _
                      "2. An Assembly or a part is the active document" & vbCrLf & _
                      "3. A Sketch feature is selected or active with nothing selected" & vbCrLf & _
                      "4. you are allowed to write to working directory.", vbInformation
          Exit Sub
          End Sub