[日积月累]：利用ObjectDbx预览块图像

雪山飞狐(lzh)

Private pFileName As String
Private objDbx As AxDbDocument
Public Names As New Collection

Private Sub Class_Initialize()

    Set objDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")
   
End Sub

Public Function GetBlock(ByVal BlockName As String) As AcadBlock
'将文件中的块读入当前图形

    Dim pBlock As AcadBlock
    Dim pnt(2) As Double
    Dim pObjs() As AcadEntity
   
    Set pBlock = objDbx.Blocks(BlockName)
   
    ReDim pObjs(pBlock.Count - 1) As AcadEntity
   
    For i = 0 To pBlock.Count - 1
        Set pObjs(i) = pBlock(i)
    Next i
   
    Set GetDbxBlock = ThisDrawing.Blocks.Add(pnt, "*U")
    objDbx.CopyObjects pObjs, GetDbxBlock
            
End Function

Public Function GetBlockImage(ByVal BlockName As String) As IPictureDisp
'获取块的预览图像

    Dim pObj(0) As AcadEntity
    Dim pnt(2) As Double
    Dim ss As AcadSelectionSet
   
    Set pObj(0) = objDbx.ModelSpace.InsertBlock(pnt, BlockName, 1, 1, 1, 0)
    objDbx.CopyObjects pObj, ThisDrawing.ModelSpace
   
    Set pObj(0) = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1)
    pObj(0).GetBoundingBox d1, d2
   
    ThisDrawing.Application.ZoomWindow d1, d2
   
    On Error Resume Next
    ThisDrawing.SelectionSets("*TlsDbx*").Delete
    Set ss = ThisDrawing.SelectionSets.Add("*TlsDbx*")
    ss.AddItems pObj
   
    ThisDrawing.Export "c:\Temp", "wmf", ss
    ss.Delete
    pObj(0).Delete
    ThisDrawing.Blocks(BlockName).Delete
    ThisDrawing.Application.ZoomPrevious
   
    Set GetBlockImage = LoadPicture("c:\temp.wmf")
    Kill "c:\temp.wmf"
   
End Function


Public Property Let FileName(ByVal str As String)
'打开文件

    Dim i As AcadBlock

    pFileName = str
    objDbx.Open str
   
    Set Names = New Collection
   
    For Each i In objDbx.Blocks
        If Not (i.IsLayout Or i.IsXRef) Then
            Names.Add i.Name
        End If
    Next i

End Property



上述代码存为TlsDbx类

插入一个窗体

加入ListBox控件和Image控件

在窗体加入下列代码

Dim a As New TlsDbx

Private Sub ListBox1_Click()
Set Me.Image1.Picture = a.GetBlockImage(ListBox1.Text)

End Sub

Private Sub UserForm_Activate()
a.FileName = "d:\ccd.dwg"
For Each i In a.Names
Me.ListBox1.AddItem i
Debug.Print i
Next i
End Sub


谢谢efan斑竹的提议，已修正过

efan2000

块有三种对象，一是布局，像模型空间，图纸空间，可以使用IsLayout来判断，二是外部引用，即将另一图纸插入到当前图纸中，可以使用IsXRef来判断，剩下的就是普通意义上的块了。