基于VBA技术实现EXCEL数据生成CASS地形图图框的方法

高化奎

关键词：VBAEXCELCASS图框

前言

在办公软件中实现程序自动化，直到20世纪90年代早期，还没有实现实质性的进展，正在接受来自各方面的挑战。Microsoft公司一直想让其开发出来的套装办公软件在实现程序自动化时共享一种通用的自动化语言，于是VBA（VisualBasicForApplication）便应运而生了。它是OFFICE及CASS等软件中集成的一种智能化编程工具，用来扩展这些软件的功能。

在深圳市1:1000地形图修补测时，由于深圳市国土资源委员会信息中心下发的分幅地形图中无图框信息，图框信息单独保存在索引文件中，而在提交成果时，按照深圳市国土资源委员会信息中心要求，各作业单位必须提交本测区满足相关作业依据、规范的1:1000分幅地形图。由于测区相当大范围内地物、地貌未发生变化，不需修测部分地形图的图框中图名、测绘单位、测绘方法等相关信息仍需沿用索引文件中的信息，但CASS已有功能无法把索引文件中相关的信息添加到与分幅图一一对应的图框中，传统作业模式中需把索引文件中的图名、测绘单位、测绘方法等相关信息人工逐个添加到分幅地形图图框中。由于大量的重复工作相当繁琐，而且容易出错，本文正是基于这种情况，介绍如何利用EXCEL和CASS提供的VBA开发工具的功能，编制程序实现该过程的自动化。

1、应用环境介绍

AUTOCAD是美国AUTODESK公司研发的通过计算机辅助设计和绘图软件。目前AUTOCAD已被广泛应用于建筑、水利、测绘等领域的设计与制图。它功能强大、界面友好、易于操作，深的广大设计、制图等人员的喜爱，但在很多领域仍有不足之处，好在AUTOCAD开放的结构体系，给了我们很大的空间来扩充新的功能和设计各种应用程序。

CASS软件是南方数码科技有限公司基于AUTOCAD平台开发的一套集地形、地籍、空间数据建库、工程应用、土石方算量等功能为一体的软件系统。CASS在拓展CAD功能的同时更是继承了其VBA（VisualBasicForApplication）开发工具。

EXCEL是微软的办公软件OFFICE的组件之一，它具有直观的界面，出色的计算和图表等功能，成为流行的数据处理软件之一。EXCEL强大的计算功能，可以方便地处理数据和通过VBA进行二次开发，在测量中有着广泛的应用。

VBA是微软提供给程序员的基于ActiveX技术的面向对象的应用程序开发工具，目前许多主流的软件，如OFFCIECASS等软件都内置了VBA开发工具，其强大的功能为各应用程序的二次开发提供了优秀的手段。VBA结构简单，代码运行效率高，而且它驻留在CASS和EXCEL内部，为实现各应用软件间的通信提供了方便。

2、工作原理

在EXCEL中，与单元格对应的是Cells（i，j），它以行号、列号作为参数，对于单元格的定位可以用cells（i，j）来表示，单元格的文字可以通过cells（i，j）.Text属性来读取。

在CASS中，通过VBA调用EXCEL索引文件中分幅地形图相应的记录并通过VBA开发工具的方法，完成相应操作，具体如下：在CASS中遍历1:1000分幅地形图，打开单幅地形图，然后通过图名遍历索引文件，找到本幅地形图对应的记录；再打开图框模板（不包括图名、测量单位、测量方法等基本信息，只包含所有地形图共用的图元），通过图框文档的AddText（）方法把索引文件中相应记录的图名、测绘单位、测量方法等信息添加图框中，添加具体图元时，调用图元的Move（）方法把图元移动到相应的位置。然后根据图名计算的图框插入点（西南角）坐标，把图框（此时已插入图名、测绘单位、测绘方法等信息）根据插入点坐标移动到相应的1:1000分幅地形图的相应位置；最后通过图框文档的CopyObjects（）方法把已插入相关信息的图框复制到1:1000相应的分幅地形图中，保存此幅分幅图，关闭且不保存图框模板。边读边写，直到结束遍历，便完成所有地形图图框的绘制工作。

3、实现步骤及主要代码

1）准备EXCEL索引文件，根据图名计算西南角坐标。表格样式如图（1）：

图1：EXCEL索引表

2）定制图框模板。图框模板只包含内图廓、外图廓、图例、比例尺注记等1:1000分幅图公用信息。图框样式如图（2）：

图2：图框模板

3）在CASS中输入VBAIDE，按ENTER打开VBA管理器，创建一个新的工程，保存在适当的位置，进入CASS的VBA开发环境。

4）打开VBA编辑器菜单的“工具\引用”菜单项，弹出对话框，选择“MicrosoftExcel11.0ObjectLibrary”项。

5）创建应用程序对象实例，部分代码如下。

OptionExplicit'所有变量必须先定义才能使用

PublicSubTK()

'定义变量

DimiAsInteger'EXCEL中的行号

DimtmAsString'图名

DimthAsString'图名

DimchdwAsString'测绘单位

DimchffAsString'测绘方法

DimxccsAsString'测绘次数

DimchrqAsString'测绘日期

DimchfffAsString'第一次动态数字化修测

DimchrqfAsString'修测日期

DimchffeAsString'测绘方法

DimchrqeAsString'测绘日期

DimszhdwAsString'测量单位

DimszhrqAsString'数字化修测日期

DimdzAsString'经理

DimjsfzAsString'工程负责人

DimctAsString'测图

DimjcAsString'检查

DimbjAsString'编辑

DimjdAsString'校对

DimYAsString'插入点Y坐标

DimXAsString'插入点X坐标

DimAcadDocTkAsAcadDocument'图框模板

DimacaddocAsAcadDocument'图框文档

DimExcelAppAsNewExcel.Application'EXCEL对象

DimPt1(2)AsDouble'图框左下角坐标

DimPt2(2)AsDouble'图框右上角坐标

DimObjAsAcadEntity'CASS实体

Dimvar(0)AsAcadModelSpace'模型空间

DimobjCollection(0)AsObject'CASS对象

DimXstringAsString'图幅号Y编号

DimYstringAsString'图幅号X编号

DimRdAsDouble

DimDtAsString

DimTxtAsAcadText

DimPlAsAcadLWPolyline

DimBlrAsAcadBlockReference

DimCirAsAcadCircle

DimnAsInteger

DimBlAsBoolean

DimLaAsAcadLayerExcelApp.Workbooks.Open"D:\TK\龙岗索引.xls"'CASS通过VBA打开EXCEL索引文档

WithExcelApp.ActiveWorkbook.Worksheets("龙岗索引")

Fori=2To[A65536].End(xlUp).Row'从第二行遍历EXCEL记录

th=.Range("B"&i)

IfDir("D:\DWG\"&Right(th,5)&".DWG")<>""Then'判断EXCEL中图幅号对应的DWG文档是否存在，如果存在就打开

SetAcadDocTk=ThisDrawing.Application.Documents.Open("D:\TK\图框.DWG")'打开TK模板

tm=.Range("A"&i)

chdw=.Range("C"&i)'变量赋值

jd=.Range("R"&i)

sm=.Range("S"&i)

X=.Range("V"&i)

Y=.Range("U"&i)

ForEachObjInAcadDocTk.ModelSpace'遍历图框模板中所有对象

'根据图幅号计算出的X、Y坐标把文字从基于原点的位置移动到正确位置

IfObj.ObjectName="AcDbText"Then

SetTxt=Obj

Pt1(0)=Txt.InsertionPoint(0)

Pt1(1)=Txt.InsertionPoint(1)

Pt2(0)=Pt1(0)+Y'Y坐标根据图幅号在EXCEL中已计算好，直接调用

Pt2(1)=Pt1(1)+X'X坐标根据图幅号在EXCEL中已计算好，直接调用

Txt.MovePt1,Pt2

EndIf

'根据图幅号计算出的X、Y坐标把多段线从基于原点的位置移动到正确位置

IfObj.ObjectName="AcDbPolyline"Then

SetPl=Obj

Pt1(0)=Pl.Coordinates(0)

Pt1(1)=Pl.Coordinates(1)

Pt2(0)=Pt1(0)+Y

Pt2(1)=Pt1(1)+X

Pl.MovePt1,Pt2

EndIf

'遍历图框模型空间把图框模板中的实体复制到地形图中

ForEachObjInAcadDocTk.ModelSpace

SetobjCollection(0)=Obj

Setvar(0)=acaddoc.ModelSpace

AcadDocTk.CopyObjectsobjCollection,var(0)

Next

'文档中如果存在NET层，BL值为TRUE

ForEachLaInacaddoc.Layers

IfLa.Name="NET"Then

acaddoc.ActiveLayer=acaddoc.Layers("NET")

Bl=True

ExitFor

EndIf

Next

'如果不存在NET层，则添加NET层

IfBl=FalseThen

acaddoc.Layers.Add"NET"

acaddoc.ActiveLayer=acaddoc.Layers("NET")

EndIf

acaddoc.Layers("NET").color=acWhite

Pt1(0)=Y+241.585'计算图号插入点坐标

Pt1(1)=X+534

'添加图号

SetTxt=acaddoc.ModelSpace.AddText(Right(th,5),Pt1,4.5)

Txt.StyleName="方正细等线体"'修改图号样式

Txt.color=acByBlock'修改图号颜色

'添加图名

Pt1(0)=Y+250-Len(tm)*3

Pt1(1)=X+525#

SetTxt=acaddoc.ModelSpace.AddText(tm,Pt1,4.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Xstring=Format(Round(X/1000,1),"0.0")'修改内图廓小数位数

Ystring=Format(Round(Y/1000),"0.0")'修改内图廓小数位数

Pt1(0)=Y+3.573'计算结合表左上图幅号坐标

Pt1(1)=X+533

'计算结合表位数，如果不够5位，则前面补充相应个数的0

IfLen(Right(th,5)-99)=4Then

SetTxt=acaddoc.ModelSpace.AddText("0"&(Right(th,5)-99),Pt1,2)

ElseIfLen(Right(th,5)-99)=3Then

SetTxt=acaddoc.ModelSpace.AddText("0"&(Right(th,5)-99),Pt1,2)

Else

SetTxt=acaddoc.ModelSpace.AddText(Right(th,5)-99,Pt1,2)

EndIf

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

'添加内图廓注记

Rd=Format(Right(Xstring,3),"0.0")'左一

Pt1(0)=Y-10

Pt1(1)=X+99.5

SetTxt=acaddoc.ModelSpace.AddText(Format(Right(Xstring,3)+0.1,"0.0"),Pt1,2.723)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

'添加测绘方法

Dt=Left(chrq,4)'动态化数字修测

Dt=Dt&"年"&Mid(chrq,6,1)

IfMid(chrq,7,1)<>"-"Then

Dt=Dt&Mid(chrq,7,1)

EndIf

Dt=Dt&"月"&xccs

Pt1(0)=Y

Pt1(1)=X-19

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

'测图方法

Dt=Left(chrqe,4)

Dt=Dt&"年"&Mid(chrqe,6,1)

IfMid(chrqe,7,1)<>"-"Then

Dt=Dt&Mid(chrqe,7,1)

EndIf

Dt=Dt&"月"&chffe

Pt1(0)=Y+62

Pt1(1)=X-19

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

'图式

Pt1(0)=Y+62

Pt1(1)=X-24

SetTxt=acaddoc.ModelSpace.AddText("2007年版图式",Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Pt1(0)=Y+414'经理

Pt1(1)=X-19

IfLen(dz)=2Then

Dt="经理："&Left(dz,1)&""&Mid(dz,2,1)

Else

Dt="经理："&dz

EndIf

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Txt.Alignment=acAlignmentMiddleLeft

Txt.TextAlignmentPoint=Pt1'修改对齐方式

'测图者

Pt1(0)=Y+450

Pt1(1)=X-19

IfLen(ct)=2Then

Dt="测图："&Left(ct,1)&""&Mid(ct,2,1)

Else

Dt="测图："&ct

EndIf

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Txt.Alignment=acAlignmentMiddleLeft

Txt.TextAlignmentPoint=Pt1

'编辑者

Pt1(0)=Y+480

Pt1(1)=X-19

IfLen(bj)=2Then

Dt="编辑："&Left(bj,1)&""&Mid(bj,2,1)

Else

Dt="编辑："&bj

EndIf

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Txt.Alignment=acAlignmentMiddleLeft

Txt.TextAlignmentPoint=Pt1

'工程负责人

Pt1(0)=Y+414

Pt1(1)=X-24

IfLen(jsfz)=2Then

Dt="工程负责人："&Left(jsfz,1)&""&Mid(jsfz,2,1)

Else

Dt="工程负责人："&jsfz

EndIf

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Txt.Alignment=acAlignmentMiddleLeft

Txt.TextAlignmentPoint=Pt1

'检查者

Pt1(0)=Y+450

Pt1(1)=X-24

IfLen(jc)=2Then

Dt="检查："&Left(jc,1)&""&Mid(jc,2,1)

Else

Dt="检查："&jc

EndIf

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Txt.Alignment=acAlignmentMiddleLeft

Txt.TextAlignmentPoint=Pt1

'校对者

Pt1(0)=Y+480

Pt1(1)=X-24

IfLen(jd)=2Then

Dt="校对："&Left(jd,1)&""&Mid(jd,2,1)

Else

Dt="校对："&jd

EndIf

SetTxt=acaddoc.ModelSpace.AddText(Dt,Pt1,2.5)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Txt.Alignment=acAlignmentMiddleLeft

Txt.TextAlignmentPoint=Pt1

'测量单位

Forn=0ToLen(chdw)–1

Pt1(0)=Y+515.31

Pt1(1)=X+0.5+4*n

SetTxt=acaddoc.ModelSpace.AddText(Mid(chdw,Len(chdw)-n,1),Pt1,2.8)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Next

Pt1(0)=Y+516.5

Pt1(1)=Pt1(1)+4

SetTxt=acaddoc.ModelSpace.AddText("：",Pt1,2.8)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Pt1(0)=Y+515.31

Pt1(1)=Pt1(1)+2

SetTxt=acaddoc.ModelSpace.AddText("位",Pt1,2.8)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Pt1(0)=Y+515.31

Pt1(1)=Pt1(1)+4

SetTxt=acaddoc.ModelSpace.AddText("单",Pt1,2.8)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Pt1(0)=Y+515.31

Pt1(1)=Pt1(1)+4

SetTxt=acaddoc.ModelSpace.AddText("量",Pt1,2.8)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

Pt1(0)=Y+515.31

Pt1(1)=Pt1(1)+4

SetTxt=acaddoc.ModelSpace.AddText("测",Pt1,2.8)

Txt.StyleName="方正细等线体"

Txt.color=acByBlock

AcadDocTk.CloseFalse'关闭图框模板，不保存，因为在此之前程序已经修改过图框模板

acaddoc.Application.ZoomExtents'把地形图在CAD窗口中全范围显示

acaddoc.Save'保存地形图

acaddoc.Close'关闭地形图

EndIf

Next

EndWith

ExcelApp.Quit'关闭并退出EXCEL

EndSub

6）本程序在WINDOWSXP操作系统中的CASS7.0和EXCEL2003的运行环境下，运行正常并达到预期结果，此时，包括图名、测量单位、测量方法等信息的图框已加入到1:1000分幅图中，单个1:1000分幅成果图如下图（3）。

图3:1:1000分幅成果图

4、结束语

本文介绍的程序通过对CASS和EXCEL内置的VBA开发工具的分析和利用，实现了根据索引文件自动绘制地形图图框，大大提高了工作效率和准确率。

参考文献：

1.孔祥丰等译.AutoCadVBA从入门到精通.北京：电子工业出版社，2001.

2.邓国成，王莉，朱宏.基于VBA的AutoCad二次开发在地质图中的应用.工程地质计算机应用，2009.

作者简介：

高化奎（1984年03月），汉族，男，学士学位，研究方向：VBA在测绘中的应用。