AnsweredAssumed Answered

Face axis mid points macro Help

Question asked by roberto gennari on Jul 12, 2014
Latest reply on Jul 15, 2014 by 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

Attachments

Outcomes