背景：从MS下转出来的DWG文件，块是无属性，且层未放进指定层，并且块的名称也不对，基于此，创建一个对照表，格式如图：

然后书写代码，如下：

'——————————————————————————————————————
'名称：pInsertBlock，这一步很重要，不然程序中无指定的块名，修改块名时将出错。
'作者：罗简单
'日期：2008-8-22
'功能：为程序添加指定名称的块，为CodeForBlock服务
'——————————————————————————————————————
Public Sub pInsertBlock(ByVal strName As String)
  Dim dblOrigin(2) As Double
  Dim strPath As String
  strPath = "D:\Program Files\CASS70\BLOCKS\" & strName & ".dwg"
 
  dblOrigin(0) = 0: dblOrigin(1) = 0: dblOrigin(2) = 0
 
  Dim pBlock As AcadBlockReference
  Set pBlock = ThisDrawing.ModelSpace.InsertBlock(dblOrigin, strPath, 1, 1, 1, 0)
  pBlock.Update
End Sub

'——————————————————————————————————————
'名称：CodeForBlock
'作者：罗简单
'日期：2008-8-21
'功能：为块添加编码，并修改块的图层
'——————————————————————————————————————
Public Sub CodeForBlock()
'连接数据库
If OpenDB = False Then Exit Sub

  '块过滤器
  Dim pType, pData
  BuildFilter pType, pData, 0, "Insert"
 
  '范围线过滤器
  Dim pType1, pData1
  BuildFilter pType1, pData1, 0, "Circle"
 
  Dim sset As AcadSelectionSet
  Set sset = CreateSelectionSet
 
  Dim sset2 As AcadSelectionSet
  Set sset2 = CreateSelectionSet2
 
  '建立块的选择集
  sset.Clear
  sset.Select acSelectionSetAll, , , pType, pData

  Dim pBlock As AcadBlockReference
  Dim strOldName As String, strNewName As String '旧、新块名
  Dim strLyr As String, strCode As String '图层、编码
  Dim strBoundary As String  '范围线
  Dim sType(1) As Integer, sData(1) As Variant
  sType(0) = 1001: sData(0) = "SOUTH"
  sType(1) = 1000
  Dim extMin, extMax
  For Each pBlock In sset
    pBlock.GetBoundingBox extMin, extMax
    sset2.Clear
    sset2.Select acSelectionSetCrossing, extMin, extMax, pType1, pData1
   
    strOldName = pBlock.Name
    'pRst.Close
    '连接字典
    LJZD "DLDW", strOldName

    Do While Not pRst.EOF
      With pRst
        '看是否有新块名，无，则删除块
        If IsNull(.Fields("新块名")) = True Then
          pBlock.Delete
          GoTo Do_Next
        Else
          strNewName = .Fields("新块名")
          '层名
          strLyr = .Fields("图层")
          '判断有无范围线
          '有，则范围线的编码为范围线字段的值，块的编码为范围线字段的值连接"-1"，有则sset2的数量为1
          '无，则块的编码为编码的值。无则sset2的数量为0
          If sset2.Count = 1 Then   '有
            Dim pCirObj As AcadCircle
            Set pCirObj = sset2.Item(0)
            strBoundary = .Fields("范围线")
            sData(1) = strBoundary
            '给范围线和块赋值
            pCirObj.SetXData sType, sData
           
            sData(1) = strBoundary & "-1"
            pBlock.SetXData sType, sData
            '修改范围线的图层
            pCirObj.Layer = strLyr
          Else                      '无
            strCode = .Fields("编码")
            sData(1) = strCode
           
            '为块赋编码
            pBlock.SetXData sType, sData
          End If
          '修改块的图层和名称
            pInsertBlock strNewName   '使用到上面的过程
            pBlock.Layer = strLyr
            pBlock.Name = strNewName
        End If
       
        .MoveNext
      End With
    Loop
   
    '设置块
    With pBlock
   
    End With
   
Do_Next:
    '关闭表
    pRst.Close
  Next pBlock
 
'关闭数据库
CloseDB

  MsgBox "修改块完毕，程序为您修改了块的编码和图层。", vbInformation, "修改块的特性"
  ThisDrawing.Application.Update  '刷新
End Sub