采用注册表的办法，可以对面状、线状、点状地类进行图斑编号

需要的配置有：菜单、CAD配置、CASS配置。

程序代码如下：

Option Explicit

Private Sub AcadDocument_EndCommand(ByVal CommandName As String)

  Select Case CommandName
    Case "DLJLINE", "LINEDLJ", "POINTDLJ"
    'DLJLINE：地类图斑
    'LINEDLJ：线状地类
    'POINTDLJ：零星地类
   
    '获得注册表中的值
    Dim strValue As String
    strValue = GetSetting("DLJ", "BH", "Value")

    strValue = Trim(Str(val(strValue) + 1)) '值+1

    '定义选择集
    Dim sset As AcadSelectionSet
    Set sset = CreateSelectionSet
   
    Dim myENT As AcadEntity
    Dim pType, pData
    Dim sType(1) As Integer
    Dim sData(1) As Variant
    sType(0) = 1001: sData(0) = "TBBH"
    sType(1) = 1000: sData(1) = strValue
   
    If CommandName = "DLJLINE" Then  '面
      BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "DLJ"

      sset.Clear
      sset.Select acSelectionSetPrevious, , , pType, pData
     
      Set myENT = sset.Item(0)
     
      myENT.SetXData sType, sData
     
      '保存编号
      SaveSetting "DLJ", "BH", "Value", strValue
    ElseIf CommandName = "LINEDLJ" Then  '线
      BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "XZDL"
     
      sset.Clear
      sset.Select acSelectionSetLast, , , pType, pData
     
      Set myENT = sset.Item(0)
     
      myENT.SetXData sType, sData
     
      '保存编号
      SaveSetting "DLJ", "BH", "Value", strValue
    Else   '点
      BuildFilter pType, pData, 0, "INSERT", 8, "LXDL"
     
      sset.Clear
      sset.Select acSelectionSetLast, , , pType, pData
     
      Set myENT = sset.Item(0)
     
      myENT.SetXData sType, sData
     
      '保存编号
      SaveSetting "DLJ", "BH", "Value", strValue
    End If
  End Select
End Sub

'————————————————————————————
'名称：DLJ_BH_CSH
'作者：罗简单
'日期：2008-9-16
'功能：地类界图斑编号的初始化
'————————————————————————————
Public Sub DLJ_BH_CSH()
  SaveSetting "DLJ", "BH", "Value", "0"
End Sub

'————————————————————————————
'名称：DLJ_BH_Reset
'作者：罗简单
'日期：2008-9-17
'功能：重新设置图斑编号
'————————————————————————————
Public Sub DLJ_BH_Reset()
  Dim InterVal As String
  InterVal = InputBox("请输入新的图斑编号：", "淳化工具", "1")
 
  Dim strValue As String
  strValue = GetSetting("DLJ", "BH", "Value")
  Dim newValue As Double
  newValue = val(InterVal) - 1
   
  strValue = Trim(Str(newValue))
 
  '保存编号
  SaveSetting "DLJ", "BH", "Value", strValue
End Sub

'创建过滤器的函数
Public Sub BuildFilter(TypeArray, DataArray, ParamArray gCodes())
    Dim fType() As Integer, fData()
    Dim index As Long, i As Long
   
    index = LBound(gCodes) - 1
    For i = LBound(gCodes) To UBound(gCodes) Step 2
        index = index + 1
        ReDim Preserve fType(0 To index)
        ReDim Preserve fData(0 To index)
        fType(index) = CInt(gCodes(i))
        fData(index) = gCodes(i + 1)
    Next
    TypeArray = fType: DataArray = fData
   
End Sub

'创建空间选择集的函数
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet

    Dim ss As AcadSelectionSet
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    ss.Clear
    Set CreateSelectionSet = ss

End Function