基于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—)，男，高級工程師，注冊測繪師，主要從事工程測量技術管理工作。