8 Replies Latest reply on Jun 16, 2014 10:21 AM by Simon Turner

    Macro for translate Vertex from Model to Active sketch

    roberto gennari


      I would like to retrieve the coordinates of the vertices of a pre-selected rectangular face, but with coordinates relative to the active sketch.

      The correct coordinates relative to the pre-selected face in the figure should be:


      X 0 Y -49.27602687

      X 30-Y 49.27602687

      X 30 Y 28.00416462

      X 0 Y 28.00416462


      But the macro doesn't work correctly,

      Could you help me? I enclose also the model on which to test and a picture on the face to be selected for testing.


      Thanks to all



      Here my macro



      ' Preconditions:
      '       (1) Part or Assembly is open.
      '       (2) Face of a component is selected.
      ' Postconditions: The four vertex coordinate relative to active sketch are return

      Option Explicit

      Sub main()

          Dim pSWApp                      As SldWorks.SldWorks
          Dim pModel                      As SldWorks.ModelDoc2
          Dim pSelMgr                     As SldWorks.SelectionMgr
          Dim pSketch                     As SldWorks.Sketch
          Dim pSketchSeg                  As SldWorks.SketchSegment
          Dim pFace                       As SldWorks.Face2
          Dim swLoop                      As SldWorks.Loop2
          Dim swEdge                      As SldWorks.Edge
          Dim vEdgeArr                    As Variant
          Dim vEdge                       As Variant
          Dim swCurve                     As SldWorks.Curve
          Dim swSketch                    As SldWorks.Sketch
          Dim swSketchSeg                 As SldWorks.SketchSegment
          Dim swXForm                     As SldWorks.MathTransform
          Dim swMathUtil                  As SldWorks.MathUtility
          Dim swMathStartPt               As SldWorks.MathPoint
          Dim swMathEndPt                 As SldWorks.MathPoint

          Dim vMidPts                     As Variant
          Dim vCurveParam                 As Variant
          Dim nStartPt(2)                 As Double
          Dim nEndPt(2)                   As Double
          Dim nEdgeCount                  As Long
          Dim i                           As Long
          Dim j                           As Long
          Dim bRet                        As Boolean
          Dim boolstatus                  As Boolean

          Set pSWApp = CreateObject("SldWorks.Application")
          Set pModel = pSWApp.ActiveDoc
          Set pSelMgr = pModel.SelectionManager
          Set pFace = pSelMgr.GetSelectedObject6(1, 0)

          If pFace Is Nothing Then
              boolstatus = pSWApp.SendMsgToUser2("Please select a face", _
                                                  swMbWarning, swMbOk)
              Exit Sub
          End If

          pModel.InsertSketch2 True
          pModel.SetAddToDB True
          pModel.SetDisplayWhenAdded False  'Doesn't show the changes during
                                                                 'the program execution
          Set pSketch = pModel.GetActiveSketch2
          Set swXForm = pSketch.ModelToSketchTransform 'Transform from model to sketch
          Set swMathUtil = pSWApp.GetMathUtility
          'Find loops of closed edges on the selected surface
          Set swLoop = pFace.GetFirstLoop
          While Not swLoop Is Nothing
              i = i + 1
              Debug.Print "Loop(" & i & ")"
              Debug.Print "  IsOuter    = " & swLoop.IsOuter
              Debug.Print "  IsSingular = " & swLoop.IsSingular
              Debug.Print ""
              'Find the outer loop
              If swLoop.IsOuter Then
                  vEdgeArr = swLoop.GetEdges: Debug.Assert UBound(vEdgeArr) >= 0
                  nEdgeCount = swLoop.GetEdgeCount
                  'Even number of edges are available here.
                  If Not nEdgeCount Mod 2 = 0 Then
                      boolstatus = pSWApp.SendMsgToUser2( _
                              "Please select the rectangular face...", _
                              swMbWarning, swMbOk)
                              pModel.InsertSketch2 True
                              bRet = pModel.EditRebuild3: Debug.Assert bRet
                      Exit Sub
                  End If

      'Here start the problem
                  i = 0
                  For Each vEdge In vEdgeArr
                      Set swEdge = vEdge
                      vCurveParam = swEdge.GetCurveParams2

                      For j = 0 To 1
                          nStartPt(j) = vCurveParam(j)
                          nEndPt(j) = vCurveParam(j)
                      Set swMathStartPt = swMathUtil.CreatePoint((nStartPt))
                      Set swMathStartPt = swMathStartPt.MultiplyTransform(swXForm)
                      Set swMathEndPt = swMathUtil.CreatePoint((nEndPt))
                      Set swMathEndPt = swMathEndPt.MultiplyTransform(swXForm)
                      Debug.Print "Edge " & j & " X:" & (swMathStartPt.ArrayData(0) * 1000#) & " Y:" & (swMathStartPt.ArrayData(1) * 1000#) & " Z:" & (swMathStartPt.ArrayData(2) * 1000#)

                      Next j

                  Next vEdge

              End If
              Set swLoop = swLoop.GetNext
          pModel.SetDisplayWhenAdded True
          pModel.SetAddToDB False

      End Sub