[求助]：如何用VBA合并图块

chuan

如何创建一条：“function combin2blockto1(blockID1 as string,blockid2 as string)as string”的命令，来实现将两个已知ID号的图块合为一个图块，并反回新的图块ID。
小弟刚接触VBA，对很多函数都不怎么了解，还请各位大虾指点帮助。谢谢。

efan2000

参考下面的代码，根据自己的需要增删。

2. 
   
3.   [FONT=courier new]
   
4. Sub Combine2Block(ByVal BlockID1 As String, ByVal BlockID2 As String, ByVal BlockID3 As String)
   
5.     Dim BlockObj1 As AcadBlock
   
6.     Dim Blockobj2 As AcadBlock
   
7.     Dim iPt(0 To 2) As Double
   
8.     Dim BlockObj3 As AcadBlock
   
9.     Dim EntObj(0) As AcadEntity
   
10.     Dim i As Integer
    
11. 
    
12.     On Error Resume Next
    
13.     Set BlockObj1 = ThisDrawing.Blocks(BlockID1)
    
14.     If Err.Number <> 0 Then Exit Sub '检查名称为BlockID1的块是否存在
    
15.     Set Blockobj2 = ThisDrawing.Blocks(BlockID2)
    
16.     If Err.Number <> 0 Then Exit Sub '检查名称为BlockID2的块是否存在
    
17.     iPt(0) = 0: iPt(1) = 0: iPt(2) = 0
    
18.     Set BlockObj3 = ThisDrawing.Blocks.Add(iPt, BlockID3)
    
19.     If Err.Number <> 0 Then Exit Sub '创建名称为BlockID3的块
    
20.     On Error GoTo ErrTrap
    
21.     For i = 0 To BlockObj1.Count - 1
    
22.         Set EntObj(0) = BlockObj1(i)
    
23.         ThisDrawing.CopyObjects EntObj, BlockObj3 '将第一个块中的实体依次拷贝到新块中
    
24.     Next
    
25.     For i = 0 To Blockobj2.Count - 1
    
26.         Set EntObj(0) = Blockobj2(i)
    
27.         ThisDrawing.CopyObjects EntObj, BlockObj3 '将第二个块中的实体依次拷贝到新块中
    
28.     Next
    
29.     ThisDrawing.ModelSpace.InsertBlock iPt, BlockObj3.Name, 1, 1, 1, 0 '在模型空间插入新块
    
30.     Exit Sub
    
31.    
    
32. ErrTrap:
    
33.     On Error GoTo 0
    
34. End Sub
    
35.   [/FONT]
    

<br />   [FONT=courier new]<br /> Sub Combine2Block(ByVal BlockID1 As String, ByVal BlockID2 As String, ByVal BlockID3 As String)<br />     Dim BlockObj1 As AcadBlock<br />     Dim Blockobj2 As AcadBlock<br />     Dim iPt(0 To 2) As Double<br />     Dim BlockObj3 As AcadBlock<br />     Dim EntObj(0) As AcadEntity<br />     Dim i As Integer<br /> <br />     On Error Resume Next<br />     Set BlockObj1 = ThisDrawing.Blocks(BlockID1)<br />     If Err.Number <> 0 Then Exit Sub '检查名称为BlockID1的块是否存在<br />     Set Blockobj2 = ThisDrawing.Blocks(BlockID2)<br />     If Err.Number <> 0 Then Exit Sub '检查名称为BlockID2的块是否存在<br />     iPt(0) = 0: iPt(1) = 0: iPt(2) = 0<br />     Set BlockObj3 = ThisDrawing.Blocks.Add(iPt, BlockID3)<br />     If Err.Number <> 0 Then Exit Sub '创建名称为BlockID3的块<br />     On Error GoTo ErrTrap<br />     For i = 0 To BlockObj1.Count - 1<br />         Set EntObj(0) = BlockObj1(i)<br />         ThisDrawing.CopyObjects EntObj, BlockObj3 '将第一个块中的实体依次拷贝到新块中<br />     Next<br />     For i = 0 To Blockobj2.Count - 1<br />         Set EntObj(0) = Blockobj2(i)<br />         ThisDrawing.CopyObjects EntObj, BlockObj3 '将第二个块中的实体依次拷贝到新块中<br />     Next<br />     ThisDrawing.ModelSpace.InsertBlock iPt, BlockObj3.Name, 1, 1, 1, 0 '在模型空间插入新块<br />     Exit Sub<br />     <br /> ErrTrap:<br />     On Error GoTo 0<br /> End Sub<br />   [/FONT]<br />

chuan

那两个块插入新块时他们所在位置和旋转角度该怎么确定？

efan2000

用CopyObjects方法并不会改变新生成实体的位置和旋转角度，它们在原来块中是什么位置，到了新块中还是什么位置，如果需要改变的话，在新块中直接操作实体就行了。

chuan

如果是当前窗体上有两个独立的图块，需要根据他们当前所在的相对位置和旋转角度来创建一个新图块，用这行吗？
并且用什么函数能分别返回这两个选中图块的ID号

efan2000

当前窗体上有两个独立的图块？指的是块引用吧，它的名称和块名称是一样的，可直接用Name属性来获取。至于怎么根据原来的块合并创建新块，要自己看看位置和旋转角度有没有变化，再来更改新块中实体的属性了。

chuan

那是不是说先得从这两个块上读出他们的ID号，NAME，基点，和旋转角度。再在新建块时输入这些讯息，才能创建出要求的新块。

efan2000

操作时直接用块对象的Name，而不用ID（ObjectID？对象ID号）或者Index（块集合中的索引），原因是ObjectID是变化的和数值型的，Index也是数值型的，通过Name就可以直接获取想要的块。
关于新块中实体的位置和旋转角度，还是自己实验一下，看看要不要做出改变。
新建块如果想做成匿名块则不需要另外指定名称，创建时用*U来代替名称即可。

chuan

那做一个选择集，并分别读出他们的NAME，代码大致是怎么样的？
我刚开始接触VBA，对那些函数都不怎么了解。

efan2000

将块插入到图纸中的实体称为块引用。块引用的名称与块的名称是一样的。因而获取块的名称的方法一是对块集合进行枚举，依次查找每个块的名称，检查是否是自己所需要的。方法二是选择块引用，可以用GetEntity来得到一个实体，并用TypeOf 选择到的实体对象 Is AcadBlockReference来判断是不是块引用，还可以构造一选择集，用过滤机制。如：

2. 
   
3.   [FONT=courier new]
   
4.     Dim fType(0) As Integer
   
5.     Dim fData(0) As Variant
   
6.     fType(0) = 0: fData(0) = "INSERT"
   
7.     选择集对象.Select acSelectionSetAll, , fType, fData
   
8.   [/FONT]
   

<br />   [FONT=courier new]<br />     Dim fType(0) As Integer<br />     Dim fData(0) As Variant<br />     fType(0) = 0: fData(0) = "INSERT"<br />     选择集对象.Select acSelectionSetAll, , fType, fData<br />   [/FONT]<br />

chuan

fType(0) 和fData(0) = "INSERT"分别代表了什么？

efan2000

这个可要看看帮助文件或者相关资料了，它的内容太丰富了。简单的说过滤机制中应包括组码及值，如组码为0，代表选择某一类的实体，值为INSERT，代表为块引用对象，组码为62，代表选择某一颜色的实体，值为acRed，代表为红色。