基于地形图符号块消隐的解决方案

摘要：在数字地形图生产的过程中，符号块消隐的好坏直接影响到图面的整饰质量，利用CAD软件提供的消隐功能无法满足生产的需要，只有二次开发程序，才能予以解决。本文主要是在AutoCAD 2004平台下利用VBA语言编写程序来实现对地形图符号块的消隐。

关 键 词：AutoCAD 2004VBA语言 地形图符号块消隐 程序实现

0 引言

数字地形图质量主要包括数学精度、地理精度、整饰质量和附件质量。每一部分质量的好坏直接影响到整体质量。其中符号块消隐的好坏直接影响到图面的整饰质量。

我院地形图编辑软件是AutoCAD平台下的广州开思SCAS系统，系统没有符号块批量消隐功能，逐个消隐费时费力，且消隐面不稳定，有时丧失消隐功能，增加了生产成本。

为了解决符号块消隐问题，我们在AutoCAD 2004平台下利用VBA语言编写了符号块批量消隐程序。

编程思路

符号块消隐主要是使用块参照的GetBoundingBox方法获得块参照的限制框角点，然后利用限制框的角点作为基础，创建块参照的消隐面。

2程序设计

2.1建立工程

在AutoCAD 2004中，打开【VBA管理器】对话框，新建一个工程，将其保存在适当位置，进入VBA集成开发环境。选择【插入/用户窗体】菜单项，向程序中添加一个用户窗体，并且放置如下图所示的控件。

2.2 编写宏的启动代码

在【工程资源管理器】窗口中双击ThisDrawing，打开模块的代码窗口添加如下代码：

SubBlockManage ()

Form1.Show

End Sub

2.3【符号块列表】按钮

按钮包含了刷新块和块参照信息，更新列表框的功能，代码如下：

Private Sub UserForm_Initialize()

Refresh

txtCount.Enabled = False

txtAtt.Enabled = False

End Sub

其中Refresh函数为自定义函数，代码如下：

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 Sub

上面代码中，RefreshList和GetBlocks函数为自定义函数，GetBlocks函数用于获得当前图形中可用的符号块列表，代码如下：

Private 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 Function

RefreshList函数用于更新列表框的信息，代码如下：

Private 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

AddSorted函数为自定义函数，代码如下：

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.ListCount - 1)

If StrComp(lstObject.List(iCount), sItem, vbTextCompare) = 1 Then

GoTo Finish

End If

Next

lstObject.AddItem sItem

Finish:

End Sub

2.4【数量】和【属性】按钮

求取符号块数量和属性，代码如下：

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.Text = i

End Sub

2.5【单块消隐】按钮

按钮包含了当前图形中单个符号块的消隐功能，代码如下：

Private Sub cmdMark_Click()

Dim ptMin, ptMax

Dim blkRef As AcadBlockReference

Dim objEnt As AcadEntity

Dim objRec As AcadLWPolyline

Dim dataType(0 To 1) As Integer

Dim data(0 To 1) As Variant

dataType(0) = 1001: data(0) = "thisApplication"

dataType(1) = 1000: data(1) = "blkMark"

For Each objEnt In ThisDrawing.ModelSpace

If TypeOf objEnt Is AcadBlockReference Then

Set blkRef = objEnt

If blkRef.Name = lstBlocks.Text Then

blkRef.GetBoundingBox ptMin, ptMax

Set objRec = AddRectangle(ptMin, ptMax, 2)

objRec.color = 151

objRec.SetXData dataType, data

objRec.Update

End If

End If

Next

End Sub

2.6【所有块消隐】按钮

按钮包含了当前图形中所有的块消隐功能，代码如下：

Private Sub cmdMarkAll_Click()

Dim ptMin, ptMax

Dim blkRef As AcadBlockReference

Dim objRec As AcadLWPolyline

Dim dataType(0 To 1) As Integer

Dim data(0 To 1) As Variant

dataType(0) = 1001: data(0) = "thisApplication"

dataType(1) = 1000: data(1) = "blkMark"

For Each blkRef In ThisDrawing.ModelSpace

blkRef.GetBoundingBox ptMin, ptMax

Set objRec = AddRectangle(ptMin, ptMax, 2)

objRec.color = 151

objRec.SetXData dataType, data

objRec.Update

Next blkRef

End Sub

2.7【删除所有消隐】按钮

按钮包含了删除图形中所有消隐面的功能，代码如下：

Private Sub cmdDelAll_Click()

Dim SSet As AcadSelectionSet

On Error Resume Next

If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then

Set SSet = ThisDrawing.SelectionSets.Item("this")

SSet.Delete

End If

Set SSet = ThisDrawing.SelectionSets.Add("this")

Dim filterType(1) As Integer

Dim filterData(1) As Variant

filterType(0) = 0: filterData(0) = "LwPolyline"

filterType(1) = 1001: filterData(1) = "thisApplication"

SSet.Select acSelectionSetAll, , , filterType, filterData

SSet.Erase

SSet.Delete

ThisDrawing.Regen acActiveViewport

End Sub

2.8【刷新列表】和【退出】按钮

代码如下：

Private Sub cmdRefresh_Click()

Refresh

End Sub

Private Sub cmdExit_Click()

Unload Me

End Sub

3 运行

(1)在AutoCAD 2004图形窗口中，打开一个地形图文件

(2)在VBA集成开发环境中，按下F5键运行程序，系统会弹出界面如下图：

程序运行界面 消隐后结果界面

4 程序功能

(1)程序能够自动对文件内的单符号块或所有符号块实现消隐。

(2)程序能够自动对文件内的所有符号块实现去除消隐面。

(3)程序运行速度较快，在数字地形图生产过程中，能够成倍提高生产效率。

5 结束语

在数字地形图生产过程中，国内很多的地形图编辑软件都是建立在AutoCAD平台下的，因而利用VBA语言可以根据不同的需求进行二次开发，能够增强编辑软件功能，使成果数据更能满足规范和设计要求，同时提高了生产效率，降低了生产成本。

注：文章内的图表及公式请到PDF格式下查看