折弯标注宏

Mloser

   经典图书

我抛砖，大家来完善！！！！！！！

Mloser

ju01668112 发表于 2023-12-1 16:16
Dim swApp As SldWorks.SldWorks
Dim model As ModelDoc2
Dim swdrw As DrawingDoc

你这代码我研究了下，，标注效果比我的代码还差啊

jsjfz0415

   经典图书

感谢分享好工具，学习~

qqfly332211

感谢楼主分享，很不错！

ju01668112

   经典案例图书

Dim swApp As SldWorks.SldWorks
Dim model As ModelDoc2
Dim swdrw As DrawingDoc
Dim swselmgr As SelectionMgr
Dim swview As View
Public swEdge As Edge
Dim swentity As Entity
Dim swcurve As Curve
Dim swCurveParaData As SldWorks.CurveParamData
Dim swLoop As SldWorks.Loop2
Dim swSelData As SldWorks.SelectData
Dim swFace As SldWorks.Face2
Public loop_arr()
Public collect_count
Public goal_line_count
Dim temp_edge_box()

Sub SelectLoop(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swLoop As SldWorks.Loop2, swSelData As SldWorks.SelectData)
    Dim vEdgeArr As Variant
    Dim vEdge As Variant
    Dim swEdge As SldWorks.Edge
    Dim swEnt As SldWorks.Entity
    Dim bRet As Boolean
    vEdgeArr = swLoop.GetEdges
    Debug.Assert Not IsEmpty(vEdgeArr)
    For Each vEdge In vEdgeArr
        Set swEdge = vEdge
        Set swEnt = swEdge
        bRet = swEnt.Select4(True, swSelData)
    Next
End Sub

Function pop_array_item(arr, index)

    Dim temp_box()
    If Not UBound(arr) = 0 Then
        ReDim Preserve temp_box(UBound(arr) - 1)
        
        j = 0
        For i = 0 To UBound(arr)
            If i <> index Then
                Set temp_box(j) = arr(i)
                j = j + 1
            End If
        Next
        pop_array_item = temp_box
    End If
   
End Function
Function get_valid_index(k, ope, num)

    a = UBound(loop_arr) * 3 - 1
    ReDim new_arr(a)
    For i = 0 To UBound(loop_arr) - 1
       new_arr(i) = i
        new_arr(i + UBound(loop_arr)) = i
        new_arr(i + UBound(loop_arr) * 2) = i
   
    Next

    If ope = "+" Then
        get_valid_index = new_arr(UBound(loop_arr) + k + num)
    ElseIf ope = "-" Then
        get_valid_index = new_arr(UBound(loop_arr) + k - num)
    End If



End Function


Sub search_next_edge(cur_swCurveParaData, vEdges, searchtype)

    If searchtype = 1 Then
        a = cur_swCurveParaData.EndPoint
    Else
        a = cur_swCurveParaData.StartPoint
    End If
   
    ReDim Preserve temp_edge_box(0)
    For i = 0 To UBound(vEdges)
        Set swEdge = vEdges(i)
        Set swCurveParaData = swEdge.GetCurveParams3
        b = swCurveParaData.StartPoint
        c = swCurveParaData.EndPoint
        
        Dim d(2)
        'match at start point
        If a(0) = b(0) And a(1) = b(1) And a(2) = b(2) Then
            Debug.Print "match at start point"
            Set d(0) = swEdge
            d(1) = i
            d(2) = 1
            temp_edge_box(UBound(temp_edge_box)) = d
            ReDim Preserve temp_edge_box(UBound(temp_edge_box) + 1)
        'match at end point
        ElseIf a(0) = c(0) And a(1) = c(1) And a(2) = c(2) Then
            Debug.Print "match at end point"
            Set d(0) = swEdge
            d(1) = i
            d(2) = 2
            temp_edge_box(UBound(temp_edge_box)) = d
            ReDim Preserve temp_edge_box(UBound(temp_edge_box) + 1)
        End If
        
    Next

    ReDim Preserve temp_edge_box(UBound(temp_edge_box) - 1)
   
    ''''when the case there are intersection
    'this algorithm choose the longer line
    If UBound(temp_edge_box) = 1 Then
        index = 0
        cur_len = 0
        
        
        Set cur_curve = temp_edge_box(0)(0).GetCurve
        vCurveParam = temp_edge_box(0)(0).GetCurveParams2
        Set swCurveParaData1 = temp_edge_box(0)(0).GetCurveParams3
        len1 = cur_curve.GetLength2(vCurveParam(6), vCurveParam(7))
        Debug.Print len1
        
        Set cur_curve = temp_edge_box(1)(0).GetCurve
        vCurveParam = temp_edge_box(1)(0).GetCurveParams2
        Set swCurveParaData2 = temp_edge_box(1)(0).GetCurveParams3
        len2 = cur_curve.GetLength2(vCurveParam(6), vCurveParam(7))
        Debug.Print len2
        
        
        
        
        If len1 < len2 Then
            searchtype = temp_edge_box(1)(2)
            Set loop_arr(UBound(loop_arr)) = temp_edge_box(1)(0)
            ReDim Preserve loop_arr(UBound(loop_arr) + 1)
            vEdges = pop_array_item(vEdges, temp_edge_box(1)(1))
            vEdges = pop_array_item(vEdges, temp_edge_box(0)(1))
            Set swCurveParaData = swCurveParaData2
            GoTo next_line

        Else
            searchtype = temp_edge_box(0)(2)
            Set loop_arr(UBound(loop_arr)) = temp_edge_box(0)(0)
            ReDim Preserve loop_arr(UBound(loop_arr) + 1)
            vEdges = pop_array_item(vEdges, temp_edge_box(1)(1))
            vEdges = pop_array_item(vEdges, temp_edge_box(0)(1))
            Set swCurveParaData = swCurveParaData1
            GoTo next_line

        End If
    Else
   
        searchtype = temp_edge_box(0)(2)
        Set swCurveParaData = temp_edge_box(0)(0).GetCurveParams3
        Set loop_arr(UBound(loop_arr)) = temp_edge_box(0)(0)
        ReDim Preserve loop_arr(UBound(loop_arr) + 1)
        vEdges = pop_array_item(vEdges, temp_edge_box(0)(1))
        
  
next_line:

        Set swentity = loop_arr(UBound(loop_arr) - 1)
        swentity.Select False
        
        If Not goal_line_count = UBound(loop_arr) Then
            search_next_edge swCurveParaData, vEdges, searchtype
        End If
        Debug.Print "!!"
    End If
   
   
   
End Sub
Function select_loop()

    For i = 0 To UBound(loop_arr) - 1
        Set swentity = loop_arr(i)
        swentity.Select True
    Next
   
End Function

Sub main()

    Set swApp = Application.SldWorks
    Set model = swApp.ActiveDoc
    Set swdrw = model
    Set swselmgr = model.SelectionManager
    Set swview = swdrw.ActiveDrawingView
    If swview Is Nothing Then
        swApp.SendMsgToUser "Please select a view"
        End
    End If
   
   
    vComps = swview.GetVisibleComponents
    vEdges = swview.GetVisibleEntities2(vComps(0), swViewEntityType_Edge)
    vVertex = swview.GetVisibleEntities2(vComps(0), swViewEntityType_Vertex)
   
    'calculate bend parameters
    bend_Count = (UBound(vEdges) - UBound(vVertex)) / 2
    bend_line_count = bend_Count * 2
    goal_line_count = UBound(vEdges) - bend_line_count + 1

    'sort loop line
    ReDim Preserve loop_arr(0)
    For i = 0 To UBound(vEdges)
   
        Set swEdge = vEdges(i)
        Set swCurveParaData = swEdge.GetCurveParams3
        
        
        Debug.Print swCurveParaData.CurveType
        '3001 : LINE_TYPE
        '3002 : CIRCLE_TYPE
   
        
        
        Set swcurve = swEdge.GetCurve
        Set swentity = swEdge
        swentity.Select False
        
        
        If swCurveParaData.CurveType = "3002" Then
            If UBound(loop_arr) = 0 Then
                Set loop_arr(UBound(loop_arr)) = swEdge
                ReDim Preserve loop_arr(UBound(loop_arr) + 1)
                vEdges = pop_array_item(vEdges, i)
                search_next_edge swCurveParaData, vEdges, 1
                Exit For
            End If
        End If
        

    Next
   
    'pick key index
    k = 0
    len1 = 0
    For i = 0 To UBound(loop_arr) - 1
   
        Set swEdge = loop_arr(i)
        vCurveParam = swEdge.GetCurveParams2
        Set swCurveParaData = swEdge.GetCurveParams3

        Debug.Print swCurveParaData.CurveType
        Set swcurve = swEdge.GetCurve
        Set swentity = swEdge
        
        
        If swCurveParaData.CurveType = "3002" Then
            If len1 = 0 Then
                k = i
                len1 = swcurve.GetLength2(vCurveParam(6), vCurveParam(7))
            Else
                len2 = swcurve.GetLength2(vCurveParam(6), vCurveParam(7))
               
                If len2 > len1 Then
                    k = i
                End If
            End If
            
            
        End If
    Next
   
    'create point
    model.ClearSelection2 True
    Dim skPoint As SketchPoint
    Set skPoint = model.SketchManager.CreatePoint(0#, 0#, 0#)
    Set swentity = loop_arr(get_valid_index(k, "+", 1))
    swentity.Select True
    Set swentity = loop_arr(get_valid_index(k, "-", 1))
    swentity.Select True
    model.SketchAddConstraints "sgATINTERSECT"

    'dim1
    model.ClearSelection2 True
    skPoint.Select True
    Set swentity = loop_arr(get_valid_index(k, "-", 2))
    swentity.Select True
    Set myDisplayDim1 = model.AddDimension2(2.89904912802659E-02, 0.116787613208301, 0)
    Status = model.Extension.AlignDimensions(swAlignDimensionType_e.swAlignDimensionType_AutoArrange, 0.001)
   
    'dim2
    model.ClearSelection2 True
    skPoint.Select True
    Set swentity = loop_arr(get_valid_index(k, "+", 2))
    swentity.Select True
    Set myDisplayDim2 = model.AddDimension2(2.89904912802659E-02, 0.116787613208301, 0)
    Status = model.Extension.AlignDimensions(swAlignDimensionType_e.swAlignDimensionType_AutoArrange, 0.001)
   


'    Set swentity = loop_arr(k)
'    swentity.Select False
'Part.SketchAddConstraints ("sgATINTERSECT")
End Sub

samsun288

楼主太有才了，膜拜中……

zxt0824

   经典案例图书

顶一下，坐等高手！

lengxiaxi

这样的就不行了。

yni621

楼主辛苦了！

3869

   经典图书

好好学习，天天向上！

sunsu168

楼主太有才了，膜拜中……

DFFDSGG114485

赞一个，这个宏越来越完善，现在标出来有点乱

wanghf1006

好品数字
感谢楼主分享，很不错！

黄火山

感谢楼主分享，很不错！

wxn153

加入QQ群
参与讨论和学习

或扫描二维码加入

活到老学到老！

weiyw1989

   经典案例图书

感谢楼主分享，很不错！

hjr123

加入QQ群
参与讨论和学习

或扫描二维码加入

楼主辛苦了！

richiwei

   经典案例图书

楼主辛苦了！

zzzm123

谢谢分享！

zzzm123

谢谢分享！