急求:将圆批量转为块的程序

usercoolbo

最近急需一个能将一个图形里的所有圆一次性转成块的程序,请各位大侠帮帮忙啊,不然我就死定了

BDYCAD

那圖里面如有很多圓. 是不是一個圓一個塊名呢? 還是所有的圓做成一個塊?

usercoolbo

如果一个圆里边还有圆的话,就以它们的公共圆心为准,对于单个的圆就以圆心为准好了,谢谢了,在线等待中

mccad

还没搞清楚你的需求，是指将图中所有的圆转换为一个图块，还是将图中每个单独的图均转换为一个单独的图块，然后如果多个圆是同心的话，则将这些同心的圆转换为一个图块。图块的名称有何要求，还是任意的名称。

usercoolbo

将图中每个单独的图均转换为一个单独的图块，如果多个圆是同心的话，则将这些同心的圆转换为一个图块,名称没有要求,谢哈

mccad

3. Sub CircleToBlock()
4.        On Error Resume Next
5.        Dim ss As AcadSelectionSet
6.        Set ss = CreateSelectionSet
7.        Dim typeArray As Variant
8.        Dim dataArray As Variant
9.        BuildFilter typeArray, dataArray, 0, "Circle"
10.        ss.Select acSelectionSetAll, , , typeArray, dataArray
11.        If ss.Count > 0 Then
12.                Dim EntCircle As AcadCircle
13.                Dim CS As AcadSelectionSet
14.                Dim tArray As Variant
15.                Dim dArray As Variant
16.                Dim Center As Variant
17.                Dim Blk As AcadBlock
18.                Dim BlkRef As AcadBlockReference
19.                Dim Ents As Variant
20.                Dim i As Integer
21.                For i = 0 To ss.Count - 1
22.                        Set CS = CreateSelectionSet("circle")
23.                        Set EntCircle = ss(i)
24.                        Center = EntCircle.Center
25.                        BuildFilter tArray, dArray, 0, "Circle", 10, Center
26.                        CS.Select acSelectionSetAll, , , tArray, dArray
27.                        Debug.Print CS.Count
28.                        Set Blk = ThisDrawing.Blocks.Add(Center, "*U")
29.                        Ents = ssArray(CS)
30.                        ThisDrawing.CopyObjects Ents, Blk
31.                        ThisDrawing.ModelSpace.InsertBlock Center, Blk.Name, 1, 1, 1, 0
32.                        CS.Erase
33.                Next
34.        End If
35. End Sub
36. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
37.        Dim fType() As Integer, fData()
38.        Dim index As Long, i As Long
39.        index = LBound(gCodes) - 1
40.        For i = LBound(gCodes) To UBound(gCodes) Step 2
41.                index = index + 1
42.                ReDim Preserve fType(0 To index)
43.                ReDim Preserve fData(0 To index)
44.                fType(index) = CInt(gCodes(i))
45.                fData(index) = gCodes(i + 1)
46.        Next
47.        typeArray = fType: dataArray = fData
48. End SubPublic Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
49.        On Error Resume Next
50.        ThisDrawing.SelectionSets(ssName).Delete
51.        Set CreateSelectionSet = ThisDrawing.SelectionSets.Add(ssName)
52. End Function
53. Public Function ssArray(ss As AcadSelectionSet)
54.        Dim retVal() As AcadEntity, i As Long
55.        ReDim retVal(0 To ss.Count - 1)
56.        For i = 0 To ss.Count - 1
57.                Set retVal(i) = ss.Item(i)
58.        Next
59.        ssArray = retVal
60. End Function

Sub CircleToBlock()        On Error Resume Next        Dim ss As AcadSelectionSet        Set ss = CreateSelectionSet        Dim typeArray As Variant        Dim dataArray As Variant        BuildFilter typeArray, dataArray, 0, "Circle"        ss.Select acSelectionSetAll, , , typeArray, dataArray        If ss.Count > 0 Then                Dim EntCircle As AcadCircle                Dim CS As AcadSelectionSet                Dim tArray As Variant                Dim dArray As Variant                Dim Center As Variant                Dim Blk As AcadBlock                Dim BlkRef As AcadBlockReference                Dim Ents As Variant                Dim i As Integer                For i = 0 To ss.Count - 1                        Set CS = CreateSelectionSet("circle")                        Set EntCircle = ss(i)                        Center = EntCircle.Center                        BuildFilter tArray, dArray, 0, "Circle", 10, Center                        CS.Select acSelectionSetAll, , , tArray, dArray                        Debug.Print CS.Count                        Set Blk = ThisDrawing.Blocks.Add(Center, "*U")                        Ents = ssArray(CS)                        ThisDrawing.CopyObjects Ents, Blk                        ThisDrawing.ModelSpace.InsertBlock Center, Blk.Name, 1, 1, 1, 0                        CS.Erase                Next        End If End Sub Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())        Dim fType() As Integer, fData()        Dim index As Long, i As Long        index = LBound(gCodes) - 1        For i = LBound(gCodes) To UBound(gCodes) Step 2                index = index + 1                ReDim Preserve fType(0 To index)                ReDim Preserve fData(0 To index)                fType(index) = CInt(gCodes(i))                fData(index) = gCodes(i + 1)        Next        typeArray = fType: dataArray = fData End SubPublic Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet        On Error Resume Next        ThisDrawing.SelectionSets(ssName).Delete        Set CreateSelectionSet = ThisDrawing.SelectionSets.Add(ssName) End Function Public Function ssArray(ss As AcadSelectionSet)        Dim retVal() As AcadEntity, i As Long        ReDim retVal(0 To ss.Count - 1)        For i = 0 To ss.Count - 1                Set retVal(i) = ss.Item(i)        Next        ssArray = retVal End Function

usercoolbo

我刚上来,就看到了MCCAD的回贴,真心的说句谢谢!我试试看

usercoolbo

能不能用LISP编写啊,VBA我有点看不懂,谢了

mccad

下载以下文件，然后把它放到启动组中，然后输入cb就可以执行了。这还不简单？？

wyj_007

请 meflyinge编吧，他可是高手。能不能说出编这个程序的实际用处，这样让人明白这个程序在工程实际应用中还有这个妙用。