基于VBA面积注记插件的设计及在竣工测量中的应用

陈彬，邹洋，王卫华

(宜昌市测绘大队，湖北 宜昌　443100)



基于VBA面积注记插件的设计及在竣工测量中的应用

陈彬*，邹洋，王卫华

(宜昌市测绘大队，湖北 宜昌443100)

摘要：规划竣工测量的主要工作是在整个工程全部完工后进行全面性的竣工验收测量，并出具完整的竣工报告，便于规划局核对相关指标。主要包括竣工总图的测绘、绿化面积和房产面积核算、±0高程测量及层高检核等内容，其中绿化面积和房产面积的统计工作都涉及面积注记的问题，虽然现在很多成熟的商业软件能够实现自动标注，但是针对空间扣减、定义字高等格式定义还是需要大量的人工参与，本插件主要解决面积自动注记的问题，简化测量外业部门的内业工作。关键词：CAD二次开发；面积注记；空间扣减

1引言

在规划部门竣工测量的工作中，绿化面积和房产面积核实的工作都需要用图形、表格等方式将面积明确地呈现，涉及大量的面积注记的问题。注记的字体、大小、位置等都有具体要求，实际工作中需要一个软件能最大程度地自动满足这些要求，以减少人工参与并提高作业效率，特别是针对大型社区或者复杂的商业楼的情况。面积注记插件可用来解决根据图幅大小自动定义字高、自动选择注记位置、方便的空间扣减等注记工作中最常见问题。

2实例和编程思路

2.1工程概况

某项目竣工图绿化面积统计结果(局部)如图1所示，图1中折线所在区域代表需要从主体扣除的部分。所有的统计工作有一个前提是需要提取面积的区域必须封闭，否则无法提取面积属性。如果手工输入需要逐个点取面积，在合适的位置依次注记，不仅效率低下，而且容易输入错误，仔细检查也不能保证输入准确无误。

2.2编程思路

面积注记插件主要解决注记字高的定义、注记放置位置选择和空间扣减等问题。因为图形的大小变化幅度很大，比如门房的长宽可能是几米而厂房的长宽可能是100多米，所以标注字高不能是一个固定值，需要根据图框的大小自动适应，使打印出来的字迹清晰，不能太小看不清，也不能太大压盖图形。注记位置的自动指定很困难，大部分商业软件也不能很好解决这个问题，主要原因是图形的不规则，比如“L”形建筑的注记位置指定就很困难，考虑大部分图形是比较规则的矩形或者圆形，所以本插件注记位置首选图形的中心位置，为了成果图形的美观，特殊图形的注记位置需要少量人工参与。空间扣减也是很常见的面积统计问题，须指定需要扣减的图形及扣减部分，即使大型商用程序本身不能辨识需要扣减的部分，本插件也要求操作人员指定扣减部分和需要扣减的图形。

3程序的实现

为了使插件高效、好用，首先该插件必须能剔除目标区域的文本、线段、标注等非目标对象，只选中目标区域内“多义线”和“轻量多义线”等有面积属性的对象，从而提高程序的运行效率。其次是根据指定图框的大小自动完成面积注记字高的定义。最后根据对象的位置计算其中心位置坐标，从而完成面积注记的工作。

该插件由一个自定义函数，一个主程序和一个补充程序构成。自定义的作用是响应主程序的调用，创建一个指定名称的数据集。两个程序分别实现常规的面积注记和空间扣减情形的面积注记。毕竟空间扣减的情形是少数，如果主程序每次都询问是否有扣减的需求会明显降低程序的运行效率，所以将空间扣减作为一个特例程序单独设计，有空间扣减的情形才调用，一般情况下只需要运行主程序。

3.1自定义函数

Public Function createSSet(ByVal SSetName As String) As AcadSelectionSet

Dim SSet As AcadSelectionSet

Dim i As Integer

For i=0 To ThisDrawing.SelectionSets.Count-1

Set SSet=ThisDrawing.SelectionSets.Item(i)

If StrComp(SSet.Name， SSetName， vbTextCompare)=0 Then

SSet.Delete

Exit For

End If

Next i

Set createSSet=ThisDrawing.SelectionSets.Add(SSetName)

End Function

这个自定义函数功能比较单一，通过查找主程序定义同名的选择集，如果找到同名的 选择集就先删除它再建选择集，以免冲突；如果没有找到同名的选择集，就创建一个。这里不做详细分析。

3.2主程序代码

Public Sub mjzj()

On Error Resume Next

Dim pt1 As Variant‘指定图框左上角

Dim pt2 As Variant ‘指定图框右下角

Dim zg As Double ‘定义注记的字高

Dim mj As Variant‘提取对象的面积

Dim S1 As Double

Dim text1 As AcadText

Dim minpt As Variant‘minpt和maxpt用来定义对象的中心位置

Dim maxpt As Variant

Dim i As Integer

Dim pt3(0 To 2) As Double‘定义标注位置，即对象的中心位置

Dim myset As AcadSelectionSet‘定义选择集

Dim tt(3) As Integer‘tt和dd用来定义选择对象类型

Dim dd(3) As Variant

tt(0)=-4： dd(0)="

tt(1)=0： dd(1)="lwpolyline"‘轻量多义线许可

tt(2)=0： dd(2)="polyline"‘多义线许可

tt(3)=-4： dd(3)="or>"

pt1=ThisDrawing.Utility.GetPoint(， "选择图框左上角")

If IsEmpty(pt1)=False Then

Do

pt2=ThisDrawing.Utility.GetCorner(pt1， "选择图框右下角")

pt1(0)=pt1(0)+1： pt1(1)=pt1(1) -1

pt2(0)=pt2(0) -1：pt2(1)=pt2(1)+1

zg=((pt2(1)-pt1(1)) ^ 2+(pt2(0)-pt1(0)) ^ 2) ^ 0.5 / 150‘通过计算图框对角线长度除以一个常数，来定义字高，实现字高自动调整

Set myset=createSSet("myset")

myset.Select acSelectionSetCrossing， pt1， pt2， tt， dd

For i=0 To myset.Count-1

mj=myset.Item(i).Area‘图形面积赋值给变量mj

obj.GetBoundingBox minpt， maxpt ‘得到最大最小坐标

pt3(0)=(minpt(0)+maxpt(0)) / 2-2 * zg

pt3(1)=(minpt(1)+maxpt(1)) / 2-0.5 * zg

pt3(2)=0

S1=Format(mj， "0.00")‘统一标注的格式：两位小数

If S1 <> "" Then‘剔除面积为零的对象

Set text1=ThisDrawing.ModelSpace.AddText("S=" & S1， pt3， zg)

text1.color=acRed‘完成注记，并改成醒目的红色

End If

Next i

pt1=ThisDrawing.Utility.GetPoint(， "选择图框左上角")

If Err <> 0 Then

Err.Clear

Exit Sub

End If

Loop

Else： Exit Sub

End If

End Sub

主程序支持连续调用，可以多福图依次注记直到按“ESC”为止，常规图形的注记位置不需要调整，但是异形对象需要人工调整位置。插件只注记面积大于零的对象，自动剔除线段或者不封闭的图形，降低了准备阶段图形处理的难度和工作量。

3.3空间扣减程序

Public Sub kjkj ()

On Error Resume Next

Dim s() As Variant

Dim s2 As Double

Dim max As Double

Dim s3 As Double

Dim s4 As String

Dim i As Integer

Dim myset As AcadSelectionSet

Dim pt As Variant

Set myset=createSSet("myset")

myset.SelectOnScreen

ReDim s(0 To myset.Count-1) As Variant

For i=0 To myset.Count-1

s(i)=myset.Item(i).Area

s3=s3+s(i)

If s(i) >= s(i+1) Then'选出最大值

s2=s(i)

Else： s2=s(i+1)：

End If

If s2 >= max Then

max=s2

Else：

End If

Next i

s4=Format(2 * max-s3， "0.00")

pt=ThisDrawing.Utility.GetPoint(， "放置差值位置：")

ThisDrawing.ModelSpace.AddText "S=" & s4， pt， 1

End Sub

扣减程序实现过程与主程序类似，使用过程中不需要专门指定扣减的对象，程序会根据面积的大小自动判断，支持单个或者多个对象的扣减，由于VBA本身不带MAX函数，程序中需要通过每个值大小比较来获得最大值。

4实例操作

针对图1所示楼层面积统计，调用主程序，根据程序提示选择图框的左上角和右下角，会自动生成图2所示注记，可见“S=21.67”和“S=52.03”虽然面积值没有错误，但是因为图形不规则而造成注记位置明显不合适，需要少量人工调整，调整完成的图形如图3所示。

扣减插件的应用主要针对天井等的扣除，也适用于绿化统计中管井等面积的扣除，如图4所示，花坛中有3个需要扣减的窗井，通常需要分别点出4个对象的面积，然后计算得出花坛净面积，整个过程比较繁琐。利用插件能很快解决这个问题，调用空间扣减程序后，分别点取这4个对象或者框选整个图形，程序会自动判别需要扣减的部分并将剔除扣减部分后的数据注记出来，一个步骤就能完成面积扣减的操作。

5结语

此插件基于VBA编程技术编写，比较快捷地解决了面积注记的问题，尤其针对有面积扣减需求的情形提出了解决方案，一定程度上提高了注记工作的效率和准确性，保证了成果的规范性和一致性，在本单位各部门使用过程中遇到了一些特殊情况，通过反复修改和完善，已经能稳定工作。希望通过对这一插件代码的详细解读，对一线测绘工作者的作业有所帮助。

参考文献

[1]王卫华，卢云辉. 基于VBA自动提取坐标插件的设计及在±0验线中的应用[J]. 城市勘测，2015(2)：140.

[2]王卫华，柯于衡. 基于VBA自动绘制时间-沉降量曲线插件的设计[J]. 城市勘测，2014(5)：149～152.

[3]张帆，郑立楷，卢择临等. AutoCAD VBA二次开发教程[M]. 北京：清华大学出版社，2006.

[4]张帆，郑立楷，王华杰. AutoCAD VBA开发精彩实例教程[M]. 北京：清华大学出版社，2004.

[5]李风华. AutoCAD 2002/2000 BVA开发指南[M]. 北京：清华大学出版社，2001.

[6]曾洪飞，张帆，卢择临. AutoCAD VBA&VB.NET开发基础与实例教程[M]. 北京：中国电力出版社，2008.

[7]二代龙震工作室. AutoCAD VBA函数库查询辞典[M]. 北京：中国铁路出版社，2003.

[8]Micrsoft公司. Microsoft visual basic 6.0程序员指南[M]. 北京：希望电子出版社，1998.

[9]Micrsoft公司. Microsoft visual basic 6.0语言参考手册[M]. 北京：希望电子出版社，1998.

A VBA Area Mark Program and the Usage in the Surveying and Mapping Work

Chen Bin，Zou Yang，Wang Weihua

(Yichang Surveying and Mapping Trade Society，Yichang 443100，China)

Key words：redevelop of CAD；area mark；space deduction

Abstract：The main mission of acceptance survey for planning bureau is to survey the completed project after all work and to provide a report for verification. Exactly speaking，it covers the survey of general drawing，the green area，the estate area，the floor height and so on. Statistician of green area and the estate area all concerns the problem of area mark. Although business software can achieve mark automatically，some detail work such as space deduction or the set of text height must be finished artificially. This program can solve the problem of automatic area mark，thus it will simplify a lot of artificial work.

文章编号：1672-8262(2016)03-124-03

中图分类号：P209

文献标识码：B

*收稿日期：2016—02—14

作者简介：陈彬(1962—)，男，高级工程师，注册测绘师，主要从事工程测量技术管理工作。