Option Explicit
Private Sub CommandButton5_Click()
Dim VntList As Variant
Dim sBlock As String
Dim sFile As String
Dim i As Integer
Dim pt(2) As Double
pt(0) = 0
pt(1) = 0
pt(2) = 0
sFile = "C:\Program Files\AutoCAD 2005\test.dwg" 'Drawing File
sBlock = "nut" 'Block Name located in Drawing File
VntList = GetBlockListFrom(sFile)
If UBound(VntList) >= 1 Then
For i = 1 To UBound(VntList)
If VntList(i) = sBlock Then
Call CopyBlockFrom(sFile, CStr(VntList(1)))
Call ThisDrawing.ModelSpace.InsertBlock(pt, sBlock, 1, 1, 1, 0)
Exit For
End If
Next i
End If
End Sub
Private Function GetBlockListFrom(sDwgFile As String) As Variant
Dim dbxDoc As Object
Dim sBlock() As Variant
On Error GoTo myfix
Set dbxDoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.16")
dbxDoc.Open sDwgFile
Dim Block As AcadBlock
ReDim sBlock(0)
sBlock(0) = "BlockList"
For Each Block In dbxDoc.Blocks
If Mid(Block.Name, 1, 1) <> "*" Then
ReDim Preserve sBlock(UBound(sBlock) + 1)
sBlock(UBound(sBlock)) = Block.Name
End If
Next Block
GetBlockListFrom = sBlock
Set dbxDoc = Nothing
myfix:
Err = 0
GetBlockListFrom = sBlock
Set dbxDoc = Nothing
End Function
Private Function CopyBlockFrom(sDwgFile As String, sBlock As String) As Boolean
Dim dbxDoc As Object
Dim objs As AcadBlock
Dim objb(0) As Object
On Error GoTo myfix
Set dbxDoc = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument.16")
dbxDoc.Open sDwgFile
Dim Block As AcadBlock
For Each Block In dbxDoc.Blocks
If Block.Name = sBlock Then
Set objs = Block
Exit For
End If
Next Block
Set objb(0) = objs
dbxDoc.CopyObjects objb, ThisDrawing.Database.Blocks
CopyBlockFrom = True
Set dbxDoc = Nothing
Exit Function
myfix:
Err = 0
CopyBlockFrom = False
Set dbxDoc = Nothing
End Function
