为什么我的块刷不出来？？？

passion884 · 发表于 2005-5-24 19:22:00

为什么我的文件中本来有十几个块，执行vba程序刷新后且只能得到一个，而且块中所含的物体的数量也得不到？？
代码如下：
Private Sub cmdexplode_Click()
Dim objblock As AcadBlockReference
If txtcount.Text = 0 Then
MsgBox "图形中未存在之定的块参照", vbCritical
Exit Sub
End If
For Each objblock In ThisDrawing.ModelSpace
If objblock.Name = lstblocks.Text Then
objblock.Explode
objblock.Delete
End If
Next

txtcount.Text = CInt(txtcount.Text) - 1
End SubPrivate Sub cmdgetpnt_Click()
Dim returnobject As Object
Dim elem As Object
Dim basepnt As Variant
i = 1
For Each elem In returnobject
   If elem.ObjectName = "AcDbAttributeDefinition" Then
   basepnt = i
   i = i + 1
   End If
   Next
   txtcount = basepnt
End SubPrivate Sub UserForm_Initialize()
refresh
txtcount.Enabled = False
txtatt.Enabled = False
End Sub
Sub blockmanage()
form1.Show

End Sub
Private Sub refresh()
Dim blocklist As Collection

On Error Resume Next

Set blocklist = getblocks

If blocklist Is Nothing Then
   MsgBox "当前图形中不存在任何块", vbCritical
   Exit Sub
   End If

   refreshlist lstblocks, blocklist

   If lstblocks.ListIndex = -1 Then
   lstblocks.ListIndex = 0
   End If

   Exit Sub

errhandle:
   MsgBox "在更新列表的过程中发生如下错误：" & Err.Description, vbCritical
   End

End SubPrivate Function getblocks() As Collection
Dim blocklist As New Collection
Dim icount As Long
Dim acadobject As AcadBlock

For Each acadobject In ThisDrawing.Blocks
   If acadobject.IsLayout = False Then
   blocklist.Add acadobject.Name, acadobject.Name
   End If
   Next

   If blocklist.Count > 0 Then
   Set getblocks = blocklist
   Else
   Set getblocks = Nothing
   End If
End FunctionPrivate Sub refreshlist(ByRef lstobject As ListBox, ByRef blocklist As Collection)
   lstblocks.Clear

   Dim icount As Integer
   For icount = 1 To blocklist.Count
   addsorted lstobject, blocklist(icount)
   Next
   End Sub


Private Sub lstblocks_click()
   On Error Resume Next
   Dim blockname As String
   Dim i As Integer
   Dim num As Integer
   i = 0

   txtatt.Text = "无"

   blockname = lstblocks.Text
   Dim blkref As AcadBlockReference
   For Each blkref In ThisDrawing.ModelSpace
   If blkref.Name = blockname Then
   i = i + 1
   If blkref.HasAttributes Then
   txtatt.Text = "有"
   End If
   End If
   Next blkref

   txtcount.Value = i
   End Sub
Private Sub addsorted(ByRef lstobject As ListBox, ByRef sitem As String)
   Dim icount As Long
   If lstobject.ListCount = 0 Then
   lstobject.AddItem sitem
   GoTo finish
   End If

   For icount = 0 To (lstobject.listciunt - 1)
   If StrComp(lstobject.List(icount), sitem, vbTextCompare) = 1 Then
   GoTo finish
   End If
   Next

   lstobject.AddItem sitem

finish:
   End Sub