1 Reply Latest reply on Jul 15, 2014 2:28 AM by roberto gennari

    Face axis mid points macro Help

    roberto gennari

      Hallo,

      I have a beautiful macro that I found in the web

      create two axes into a rectangular face, this macro works very well, but the axes are not costrain to the edge midpoints.

      modify the macro so that the axes are costrain to the midpoints?

      I think it could be useful to all users of the forum.

       

      This is the macro:


      ' Preconditions:
      '       (1) Part or assembly is open.
      '       (2) Face is selected.
      '
      ' Postconditions: Plane or face on which
      '                 selected sketch was drawn is selected.
      '
      '--------------------------------------

      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
                     
                  'Finding edges
                  '4 for rectangle
                  '6 for hexagon
                  '0 for circle
                  i = 0
                  ReDim vMidPts(nEdgeCount * 3)
                  For Each vEdge In vEdgeArr
                      Set swEdge = vEdge
                      vCurveParam = swEdge.GetCurveParams2

                      'vCurveParam is a array which contains 11 double type data as follows
                      '
                      'StartPtX, StartPtY, StartPtZ,
                      'EndPtX, EndPtY, EndPtZ,
                      'StartUParam, EndUParam,
                      'PackDouble1, PackDouble2, PackDouble3

                      For j = 0 To 2
                          nStartPt(j) = vCurveParam(j)
                          nEndPt(j) = vCurveParam(j + 3)
                      Next j

                      'If you use 3D sketch, you don't have to do this kind of transformation
                      'Using sketch let us need to do the transformation
                      '3D coordinate values of array(nStartPt) are
                      'assigned to vector (swMathStartPt)
                      'and then, 3D values are transformed into 2D values
                      'swXForm = pSketch.ModelToSketchTransform is
                      'the transfromation function of API to do so.
                      Set swMathStartPt = swMathUtil.CreatePoint((nStartPt))
                      Set swMathStartPt = swMathStartPt.MultiplyTransform(swXForm)
                      Set swMathEndPt = swMathUtil.CreatePoint((nEndPt))
                      Set swMathEndPt = swMathEndPt.MultiplyTransform(swXForm)
                     
                      'Transformed vector values are assinged to new array(vMidPts).
                      For j = 0 To 2
                          vMidPts(i) = (swMathStartPt.ArrayData(j) + _
                                        swMathEndPt.ArrayData(j)) / 2#
                          i = i + 1
                      Next j
                  Next vEdge

                  'In vMidPts
                  '1st edge mid-point:0,1,2
                  '2nd edge mid-point:3,4,5
                  '3rd edge mid-point:6,7,8
                  '...
                  'saved like this.
                  'mid-points is connected skipping the right next points.
                  'so, practically centerline is formed only on the rectangle
                  'If you want to apply this program to skewed surface, you can test as follows.
                  'Using pModel.CreateLine2,
                  'Draw (0,0)-(1,0), (0,0)-(0,1)
                  'You can check the sketch and space coordinates in this way.
                  On Error Resume Next
                  For i = 0 To nEdgeCount / 2 - 1
                      Set swSketchSeg = pModel.CreateLine2( _
                          vMidPts(i * 3 + 0), vMidPts(i * 3 + 1), 0, _
                          vMidPts(i * 3 + 6), vMidPts(i * 3 + 7), 0)
                      swSketchSeg.ConstructionGeometry = True

                      Debug.Print "vMidPts-from (" & i & ") = " & _
                          Format$(vMidPts(i * 3 + 0) * 1000#, "0.0000") & "," & _
                          Format$(vMidPts(i * 3 + 1) * 1000#, "0.0000") & " mm"
                      Debug.Print "vMidPts-to   (" & i & ") = " & _
                          Format$(vMidPts(i * 3 + 6) * 1000#, "0.0000") & "," & _
                          Format$(vMidPts(i * 3 + 7) * 1000#, "0.0000") & " mm"
                  Next i
                  On Error GoTo 0
              End If
              Set swLoop = swLoop.GetNext
          Wend
            
          'All changes are reflected on the screen.
          pModel.SetDisplayWhenAdded True
          pModel.SetAddToDB False

          'If you want to continue to do something within sketch mode,
          'comment out the following code this way.
          'pModel.InsertSketch2 True
          'bRet = pModel.EditRebuild3: Debug.Assert bRet
      End Sub