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
