社区 › 编程申请 › 急求:将圆批量转为块的程序

usercoolbo 发表于 2004-3-16 16:47:00

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

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

BDYCAD 发表于 2004-3-16 16:54:00

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

usercoolbo 发表于 2004-3-16 17:02:00

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

mccad 发表于 2004-3-16 18:14:00

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

usercoolbo 发表于 2004-3-16 18:35:00

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

mccad 发表于 2004-3-16 21:22:00

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 发表于 2004-3-17 08:33:00

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

usercoolbo 发表于 2004-3-17 10:46:00

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

mccad 发表于 2004-3-17 19:45:00

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

wyj_007 发表于 2004-3-17 19:57:00

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

查看完整版本: 急求:将圆批量转为块的程序