[求助]：程序调试是成功的，可是显示图形结果却是好几个图形重叠的。。。。昏！帮我！

爱好者

我在该程序里使用啦图块引用，问题大概就是出在那个地方，烦请各位大侠帮我看看，因为有窗体和数据库，我将该程序压缩上传啦！

efan2000

重叠是因为对块重复添加直线，而原来的实体还存在的原因。对于这种块不是固定大小的，一种是不做成块，另一种是做成匿名块，有关匿名块的制作，可以查看相关的主题。
下面是部分代码的修改。

2. 
   
3.   [FONT=courier new]
   
4. Dim blkobj As AcadBlock
   
5. Dim inspnt(0 To 2) As Double
   
6. inspnt(0) = 0: inspnt(1) = 0: inspnt(2) = 0
   
7. Set blkobj = ThisDrawing.Blocks.Add(inspnt, "*U") '这里用*号跟一个字母代表匿名块的名称规则，具体的名称还要看生成块以后的名称，它的后面有一个数字。
   
8. 
   
9. Dim blkrefobj As AcadBlockReference
   
10. Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(insertpnt, blkobj.Name, xscale, yscale, 1#, rotangle) '这里直接引用匿名块的名称。
    
11. 
    
12.   [/FONT]
    

<br />   [FONT=courier new]<br /> Dim blkobj As AcadBlock<br /> Dim inspnt(0 To 2) As Double<br /> inspnt(0) = 0: inspnt(1) = 0: inspnt(2) = 0<br /> Set blkobj = ThisDrawing.Blocks.Add(inspnt, "*U") '这里用*号跟一个字母代表匿名块的名称规则，具体的名称还要看生成块以后的名称，它的后面有一个数字。<br /> <br /> Dim blkrefobj As AcadBlockReference<br /> Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(insertpnt, blkobj.Name, xscale, yscale, 1#, rotangle) '这里直接引用匿名块的名称。<br /> <br />   [/FONT]<br />

fjw_ok

我是这样做的
Dim ent As AcadEntity
   
    For Each allEnt In ThisDrawing.ModelSpace
               If StrComp(allEnt.EntityName, "AcDbBlockReference", 1) = 0 Then
               Set blkRefObj = allEnt
                        If StrComp(blkRefObj.Name, "wg", 1) = 0 Then
    GoTo 123:
    End If
     End If
     Next
123:

爱好者

efan2000的方法真的简洁，很好用！谢谢你

fij_ok的方法给我啦许多提示，也谢谢你！你那一段我觉得这样更好：
Dim blkobj As AcadBlock
Dim inspnt(0 To 2) As Double
Dim allent As AcadEntity
Dim blkrefobj As AcadBlockReference
Dim blkcount As Integer
Dim blkname As String

blkcount = 0
   For Each allent In ThisDrawing.ModelSpace
         If StrComp(allent.EntityName, "AcDbBlockReference", 1) = 0 Then
            Set blkrefobj = allent
           If StrComp(Left(blkrefobj.Name, 9), "zhoucheng", 1) = 0 Then
              blkcount = blkcount + 1

           End If
         End If
   Next
blkcount = blkcount + 1

inspnt(0) = 0: inspnt(1) = 0: inspnt(2) = 0
blkname = "zhoucheng" & blkcount
Set blkobj = ThisDrawing.Blocks.Add(inspnt, blkname)
我用efan2000的方法和这个程序段都调成功啦！

efan2000

你用的CAD版本应该是R14.01的吧。
对于一个实体对象的EntityName（实体名称），在R2000的版本已不支持，统一改为用ObjectName（对象名称）。
因而，如果程序要运行在不同的CAD版本下，请注意各个版本之间的一些变化。

爱好者

呵呵，我用的是2000，entityname也能用。

刚才我用这段程序发现有个问题：
Dim blkobj As AcadBlock
Dim inspnt(0 To 2) As Double
Dim allent As AcadEntity
Dim blkrefobj As AcadBlockReference
Dim blkcount As Integer
Dim blkname As String

blkcount = 0
For Each allent In ThisDrawing.ModelSpace
If StrComp(allent.EntityName, "AcDbBlockReference", 1) = 0 Then
Set blkrefobj = allent
If StrComp(Left(blkrefobj.Name, 9), "zhoucheng", 1) = 0 Then
blkcount = blkcount + 1

End If
End If
Next
blkcount = blkcount + 1

inspnt(0) = 0: inspnt(1) = 0: inspnt(2) = 0
blkname = "zhoucheng" & blkcount
Set blkobj = ThisDrawing.Blocks.Add(inspnt, blkname

当我在同一drawing1上画该图型的时候，如果我又删除已画好的图形，再去执行该程序时就又会出现块重复现象，这是因为块还存在，那我又该怎样去修改这段代码呢？efan2000，如果用你的匿名图块会不会出现这问题？我在明经看到你对匿名图块的较详细解释，其中这一句：。。。在块集合中，匿名块的名称从第三位后必为数字，最新创建的匿名块必为最大的数字，但要保证创建后没有删除该块，否则返回的就是以前创建的了。
。。。。是不是也会遇到同样的问题？

efan2000

不会出现这种情况，因为即使块被删除了，但它后面的数字依然是递增的。在CAD中，所有的标注对象都是用这种方式。

爱好者

对于尺寸标注而言，匿名图块的用处是很大，主要是因为尺寸图块的块名没有任何意义。
而对于某些图块，当需要图块名的时候，采用匿名图块就不太合适啦，我发现采取别的办法也可以做到不出现块重复的问题，不过还是有一点局性。

[CODE]
mm=val(userform1.combobox1.text) '块名也可以用其它方式表达

dim flagno as integer
flagno=0

Dim iblock As Integer
iblock = ThisDrawing.Blocks.count

While (iblock > 0)
If ThisDrawing.Blocks.Item(iblock - 1).Name = mm Then
flagno = 1
End If
iblock = iblock - 1
Wend

If flagno = 0 Then
......没有图块，就在块中绘制图象
end if
.......图块存在，就直接插入

用这段代码不会出现块重复现象，但是如果想将块里实体放大或者缩小，好象不能做到。

rongqiu

厉害呀，以后有问题就找你们了

efan2000

提供两个判断块是否存在的函数。

2. 
   
3.   [FONT=courier new]
   
4. ' 这种是比较安全的作法。
   
5. Function BlockExists(ByVal Name As String) As Boolean
   
6.     BlockExists = False
   
7.     Dim BlockObj As AcadBlock
   
8.    
   
9.     On Error GoTo ErrTrap
   
10.     For Each BlockObj In ThisDrawing.Blocks
    
11.         If StrComp(BlockObj.Name, Name, vbTextCompare) = 0 Then
    
12.             BlockExists = True
    
13.             Exit For
    
14.         End If
    
15.     Next
    
16.     Set BlockObj = Nothing
    
17.     Exit Function
    
18. 
    
19. ErrTrap:
    
20.     On Error GoTo 0
    
21. End Function
    
22.   [/FONT]
    

<br />   [FONT=courier new]<br /> ' 这种是比较安全的作法。<br /> Function BlockExists(ByVal Name As String) As Boolean<br />     BlockExists = False<br />     Dim BlockObj As AcadBlock<br />     <br />     On Error GoTo ErrTrap<br />     For Each BlockObj In ThisDrawing.Blocks<br />         If StrComp(BlockObj.Name, Name, vbTextCompare) = 0 Then<br />             BlockExists = True<br />             Exit For<br />         End If<br />     Next<br />     Set BlockObj = Nothing<br />     Exit Function<br /> <br /> ErrTrap:<br />     On Error GoTo 0<br /> End Function<br />   [/FONT]<br />

2. 
   
3.   [FONT=courier new]
   
4. ' 这种是通过捕获错误来判断块是否存在。
   
5. Function BlockExists(ByVal Name As String) As Boolean
   
6.     BlockExists = False
   
7.     Dim BlockObj As AcadBlock
   
8.    
   
9.     On Error Resume Next
   
10.     Set BlockObj = ThisDrawing.Blocks(Name)
    
11.     If Err.Number <> 0 Then GoTo ErrTrap
    
12.     BlockExists = True
    
13.     Set BlockObj = Nothing
    
14.     Exit Function
    
15. 
    
16. ErrTrap:
    
17.     On Error GoTo 0
    
18. End Function
    
19.   [/FONT]
    

<br />   [FONT=courier new]<br /> ' 这种是通过捕获错误来判断块是否存在。<br /> Function BlockExists(ByVal Name As String) As Boolean<br />     BlockExists = False<br />     Dim BlockObj As AcadBlock<br />     <br />     On Error Resume Next<br />     Set BlockObj = ThisDrawing.Blocks(Name)<br />     If Err.Number <> 0 Then GoTo ErrTrap<br />     BlockExists = True<br />     Set BlockObj = Nothing<br />     Exit Function<br /> <br /> ErrTrap:<br />     On Error GoTo 0<br /> End Function<br />   [/FONT]<br />

对于块中的实体，跟模型的操作是一样的。一是直接在块中对其操作，二是用ThisDrawing.Utility.GetSubEntity对块引用中的实体操作，这种操作将直接影响到块中的实体。