16 Replies Latest reply on Apr 2, 2013 3:29 PM by Danijel Radenkovic

    How to get X&Y coordinates of all points

    Danijel Radenkovic

      Hello there. I have a problem to make macro for getting X&Y coordinates of all points from sketch (see a picture), but on new coordinate system. Can anyone help me?test.png

      Thanks in advance

      Danijel

        • Re: How to get X&Y coordinates of all points
          Manish Kumar

          Hi Danijel

           

          You can try something like tihs

          ....

          Set swApp = Application.SldWorks

          Dim oPart As ModelDoc2

          Set oPart = swApp.ActiveDoc

          Dim oSketch As Sketch

          Set oSketch = oPart.SketchManager.ActiveSketch 'Get Active skecth

          Dim sketchPointArray As Variant

          ' Each item of this array will give you a sketch point in the active skech

          sketchPointArray = oSketch.GetSketchPoints2

           

          Dim i As Integer

          For i = LBound(sketchPointArray) To UBound(sketchPointArray)   

              'MsgBox sketchPointArray(i).X & " " & sketchPointArray(i).Y & " " & sketchPointArray(i).Z

          Next

          ...

           

          Regards,

          Manish

          • Re: How to get X&Y coordinates of all points
            Jerry Steiger

            Danijel,

             

            You might want to ask this in the API forum. The people who can answer you best will be more likely to see it there.

             

            Jerry S.

            • Re: How to get X&Y coordinates of all points
              Danijel Radenkovic

              Hello my friends, I tried to ask this question on API section of the forum but I don't have a permission, maybe because I am new member on this forum.

              • Re: How to get X&Y coordinates of all points
                Danijel Radenkovic

                I found an macro which doing what I want, but Default coordinate system named (origin). How to modify macro to works on diferent coordinate system (in my case "Coordinate System1")?

                 

                 

                '----------------------------------------------------

                 

                ' 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

                Else

                 

                    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)) & "," & _

                            Format(zValue(i))

                   Next i

                f.Close

                       

                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

                 

                '----------------------------------------------------

                  • Re: How to get X&Y coordinates of all points
                    Ivana Kolin

                    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 swFeat1                         As SldWorks.Feature

                    Dim swFeat2                         As SldWorks.Feature

                    Dim swSketch                        As SldWorks.Sketch

                    Dim cSysData                        As SldWorks.CoordinateSystemFeatureData

                    Dim i                               As Long

                    Dim vSketchSeg                      As Variant

                    Dim swSketchSeg                     As SldWorks.SketchPoint

                    Dim xValue() As Double

                    Dim yValue() As Double

                    Dim zValue() As Double

                    Dim point_count As Integer

                    Dim sFilename As String

                    Dim fs As Object

                    Dim f As Object

                    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

                        Select Case swSelMgr.GetSelectedObjectCount2(-1)

                        Case 1

                            Set swFeat1 = swSelMgr.GetSelectedObject6(1, -1)

                            If swFeat1.GetTypeName2 = "CoordSys" Then

                                Set cSysData = swFeat1.GetSpecificFeature2

                            Else

                                MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")

                                Exit Sub

                            End If

                            Set swSketch = swModel.GetActiveSketch2

                            If swSketch Is Nothing Then

                                MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")

                                Exit Sub

                            End If

                        Case 2

                            Set swFeat1 = swSelMgr.GetSelectedObject6(1, -1)

                            Set swFeat2 = swSelMgr.GetSelectedObject6(2, -1)

                           

                            If swFeat1.GetTypeName2 = "CoordSys" Then

                                Set cSysData = swFeat1.GetDefinition

                            ElseIf swFeat2.GetTypeName2 = "CoordSys" Then

                                Set cSysData = swFeat2.GetDefinition

                            Else

                                MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")

                                Exit Sub

                            End If

                            If swFeat1.GetTypeName2 = "ProfileFeature" Then

                                Set swSketch = swFeat1.GetSpecificFeature2

                            ElseIf swFeat2.GetTypeName2 = "ProfileFeature" Then

                                Set swSketch = swFeat2.GetSpecificFeature2

                            Else

                                MsgBox ("you must select coordinate system and the sketch from feature manager tree or at least be in a sketch")

                                Exit Sub

                               

                            End If

                          

                        End Select

                     

                    Dim mu As SldWorks.MathUtility

                    Set mu = swApp.GetMathUtility

                    Dim swSkXform As SldWorks.MathTransform

                     

                     

                    Set swSkXform = swSketch.ModelToSketchTransform

                    Set swSkXform = swSkXform.Inverse

                     

                     

                     

                     

                    Dim PointCoords(2) As Double

                    Dim vPt As Variant

                       

                     

                    Dim mt As SldWorks.MathTransform

                    Dim mp As SldWorks.MathPoint

                    Set mt = cSysData.Transform

                    Set mt = mt.Inverse

                     

                    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)

                        PointCoords(0) = swSketchSeg.X

                        PointCoords(1) = swSketchSeg.Y

                        PointCoords(2) = swSketchSeg.Z

                        vPt = PointCoords

                       

                        Set mp = mu.CreatePoint(vPt)

                        Set mp = mp.MultiplyTransform(swSkXform)

                     

                     

                        Set mp = mp.MultiplyTransform(mt)

                        xValue(i) = mp.ArrayData(0) * 1000

                        yValue(i) = mp.ArrayData(1) * 1000

                        zValue(i) = mp.ArrayData(2) * 1000

                     

                     

                    Next i

                     

                     

                    sFilename = swModel.GetPathName

                    sFilename = Left(sFilename, Len(sFilename) - 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)) & "," & _

                        Format(zValue(i))

                    Next i

                    f.Close

                     

                     

                    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