关键词：VBA EXCEL CASS 图框
前言
在办公软件中实现程序自动化，直到20世纪90年代早期，还没有实现实质性的进展，正在接受来自各方面的挑战。Microsoft公司一直想让其开发出来的套装办公软件在实现程序自动化时共享一种通用的自动化语言，于是VBA（Visual Basic For Application）便应运而生了。它是OFFICE及CASS等软件中集成的一种智能化编程工具，用来扩展这些软件的功能。
在深圳市1:1000地形图修补测时，由于深圳市国土资源委员会信息中心下发的分幅地形图中无图框信息，图框信息单独保存在索引文件中，而在提交成果时，按照深圳市国土资源委员会信息中心要求，各作业单位必须提交本测区满足相关作业依据、规范的1:1000分幅地形图。由于测区相当大范围内地物、地貌未发生变化，不需修测部分地形图的图框中图名、测绘单位、测绘方法等相关信息仍需沿用索引文件中的信息，但CASS已有功能无法把索引文件中相关的信息添加到与分幅图一一对应的图框中，传统作业模式中需把索引文件中的图名、测绘单位、测绘方法等相关信息人工逐个添加到分幅地形图图框中。由于大量的重复工作相当繁琐，而且容易出错，本文正是基于这种情况，介绍如何利用EXCEL和CASS提供的VBA开发工具的功能，编制程序实现该过程的自动化。
1、应用环境介绍
AUTO CAD是美国AUTO DESK公司研发的通过计算机辅助设计和绘图软件。目前AUTO CAD已被广泛应用于建筑、水利、测绘等领域的设计与制图。它功能强大、界面友好、易于操作，深的广大设计、制图等人员的喜爱，但在很多领域仍有不足之处，好在AUTO CAD开放的结构体系，给了我们很大的空间来扩充新的功能和设计各种应用程序。
CASS软件是南方数码科技有限公司基于AUTO CAD平台开发的一套集地形、地籍、空间数据建库、工程应用、土石方算量等功能为一体的软件系统。CASS在拓展CAD功能的同时更是继承了其VBA（Visual Basic For Application）开发工具。
EXCEL是微软的办公软件OFFICE的组件之一，它具有直观的界面，出色的计算和图表等功能，成为流行的数据处理软件之一。EXCEL强大的计算功能，可以方便地处理数据和通过VBA进行二次开发，在测量中有着广泛的应用。
VBA是微软提供给程序员的基于ActiveX技术的面向对象的应用程序开发工具，目前许多主流的软件，如OFFCIE CASS等软件都内置了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编辑器菜单的“工具\引用”菜单项，弹出对话框，选择“Microsoft Excel 11.0 Object Library”项。
5）创建应用程序对象实例，部分代码如下。
Option Explicit'所有变量必须先定义才能使用
Public Sub TK()
'定义变量
Dim i As Integer 'EXCEL中的行号
Dim tm As String '图名
Dim th As String '图名
Dim chdw As String '测绘单位
Dim chff As String '测绘方法
Dim xccs As String '测绘次数
Dim chrq As String '测绘日期
Dim chfff As String '第一次动态数字化修测
Dim chrqf As String '修测日期
Dim chffe As String '测绘方法
Dim chrqe As String '测绘日期
Dim szhdw As String '测量单位
Dim szhrq As String '数字化修测日期
Dim dz As String '经理
Dim jsfz As String '工程负责人
Dim ct As String '测图
Dim jc As String '检查
Dim bj As String '编辑
Dim jd As String '校对
Dim Y As String '插入点Y坐标
Dim X As String '插入点X坐标
Dim AcadDocTk As AcadDocument '图框模板
Dim acaddoc As AcadDocument '图框文档
Dim ExcelApp As New Excel.Application 'EXCEL对象
Dim Pt1(2) As Double '图框左下角坐标
Dim Pt2(2) As Double '图框右上角坐标
Dim Obj As AcadEntity 'CASS实体
Dim var(0) As AcadModelSpace '模型空间
Dim objCollection(0) As Object 'CASS对象
Dim Xstring As String '图幅号Y编号
Dim Ystring As String '图幅号X编号
Dim Rd As Double
Dim Dt As String
Dim Txt As AcadText
Dim Pl As AcadLWPolyline
Dim Blr As AcadBlockReference
Dim Cir As AcadCircle
Dim n As Integer
Dim Bl As Boolean
Dim La As AcadLayerExcelApp.Workbooks.Open "D:\TK\龙岗索引.xls"'CASS通过VBA打开EXCEL索引文档
With ExcelApp.ActiveWorkbook.Worksheets("龙岗索引")
For i = 2 To [A65536].End(xlUp).Row '从第二行遍历EXCEL记录
th = .Range("B" & i)
If Dir("D:\DWG\" & Right(th, 5) & ".DWG") <> "" Then '判断EXCEL中图幅号对应的DWG文档是否存在，如果存在就打开
Set AcadDocTk = 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)
For Each Obj In AcadDocTk.ModelSpace'遍历图框模板中所有对象
'根据图幅号计算出的X、Y坐标把文字从基于原点的位置移动到正确位置
If Obj.ObjectName = "AcDbText" Then
Set Txt = 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.Move Pt1, Pt2
End If
'根据图幅号计算出的X、Y坐标把多段线从基于原点的位置移动到正确位置
If Obj.ObjectName = "AcDbPolyline" Then
Set Pl = Obj
Pt1(0) = Pl.Coordinates(0)
Pt1(1) = Pl.Coordinates(1)
Pt2(0) = Pt1(0) + Y
Pt2(1) = Pt1(1) + X
Pl.Move Pt1, Pt2
End If
'遍历图框模型空间把图框模板中的实体复制到地形图中
For Each Obj In AcadDocTk.ModelSpace
Set objCollection(0) = Obj
Set var(0) = acaddoc.ModelSpace
AcadDocTk.CopyObjects objCollection, var(0)
Next
'文档中如果存在NET层，BL值为TRUE
For Each La In acaddoc.Layers
If La.Name = "NET" Then
acaddoc.ActiveLayer = acaddoc.Layers("NET")
Bl = True
Exit For
End If
Next
'如果不存在NET层，则添加NET层
If Bl = False Then
acaddoc.Layers.Add "NET"
acaddoc.ActiveLayer = acaddoc.Layers("NET")
End If
acaddoc.Layers("NET").color = acWhite
Pt1(0) = Y + 241.585 '计算图号插入点坐标
Pt1(1) = X + 534
'添加图号
Set Txt = 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#
Set Txt = 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
If Len(Right(th, 5) - 99) = 4 Then
Set Txt = acaddoc.ModelSpace.AddText("0" & (Right(th, 5) - 99), Pt1, 2)
ElseIf Len(Right(th, 5) - 99) = 3 Then
Set Txt = acaddoc.ModelSpace.AddText("0" & (Right(th, 5) - 99), Pt1, 2)
Else
Set Txt = acaddoc.ModelSpace.AddText(Right(th, 5) - 99, Pt1, 2)
End If
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
'添加内图廓注记
Rd = Format(Right(Xstring, 3), "0.0")'左一
Pt1(0) = Y - 10
Pt1(1) = X + 99.5
Set Txt = 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)
If Mid(chrq, 7, 1) <> "-" Then
Dt = Dt & Mid(chrq, 7, 1)
End If
Dt = Dt & "月" & xccs
Pt1(0) = Y
Pt1(1) = X - 19
Set Txt = acaddoc.ModelSpace.AddText(Dt, Pt1, 2.5)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
'测图方法
Dt = Left(chrqe, 4)
Dt = Dt & "年" & Mid(chrqe, 6, 1)
If Mid(chrqe, 7, 1) <> "-" Then
Dt = Dt & Mid(chrqe, 7, 1)
End If
Dt = Dt & "月" & chffe
Pt1(0) = Y + 62
Pt1(1) = X - 19
Set Txt = acaddoc.ModelSpace.AddText(Dt, Pt1, 2.5)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
'图式
Pt1(0) = Y + 62
Pt1(1) = X - 24
Set Txt = acaddoc.ModelSpace.AddText("2007年版图式", Pt1, 2.5)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
Pt1(0) = Y + 414 '经理
Pt1(1) = X - 19
If Len(dz) = 2 Then
Dt = "经 理：" & Left(dz, 1) & " " & Mid(dz, 2, 1)
Else
Dt = "经 理：" & dz
End If
Set Txt = 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
If Len(ct) = 2 Then
Dt = "测图：" & Left(ct, 1) & " " & Mid(ct, 2, 1)
Else
Dt = "测图：" & ct
End If
Set Txt = 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
If Len(bj) = 2 Then
Dt = "编辑：" & Left(bj, 1) & " " & Mid(bj, 2, 1)
Else
Dt = "编辑：" & bj
End If
Set Txt = 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
If Len(jsfz) = 2 Then
Dt = "工程负责人：" & Left(jsfz, 1) & " " & Mid(jsfz, 2, 1)
Else
Dt = "工程负责人：" & jsfz
End If
Set Txt = 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
If Len(jc) = 2 Then
Dt = "检查：" & Left(jc, 1) & " " & Mid(jc, 2, 1)
Else
Dt = "检查：" & jc
End If
Set Txt = 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
If Len(jd) = 2 Then
Dt = "校对：" & Left(jd, 1) & " " & Mid(jd, 2, 1)
Else
Dt = "校对：" & jd
End If
Set Txt = acaddoc.ModelSpace.AddText(Dt, Pt1, 2.5)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
Txt.Alignment = acAlignmentMiddleLeft
Txt.TextAlignmentPoint = Pt1
'测量单位
For n = 0 To Len(chdw) – 1
Pt1(0) = Y + 515.31
Pt1(1) = X + 0.5 + 4 * n
Set Txt = 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
Set Txt = acaddoc.ModelSpace.AddText("：", Pt1, 2.8)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
Pt1(0) = Y + 515.31
Pt1(1) = Pt1(1) + 2
Set Txt = acaddoc.ModelSpace.AddText("位", Pt1, 2.8)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
Pt1(0) = Y + 515.31
Pt1(1) = Pt1(1) + 4
Set Txt = acaddoc.ModelSpace.AddText("单", Pt1, 2.8)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
Pt1(0) = Y + 515.31
Pt1(1) = Pt1(1) + 4
Set Txt = acaddoc.ModelSpace.AddText("量", Pt1, 2.8)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
Pt1(0) = Y + 515.31
Pt1(1) = Pt1(1) + 4
Set Txt = acaddoc.ModelSpace.AddText("测", Pt1, 2.8)
Txt.StyleName = "方正细等线体"
Txt.color = acByBlock
AcadDocTk.Close False '关闭图框模板，不保存，因为在此之前程序已经修改过图框模板
acaddoc.Application.ZoomExtents '把地形图在CAD窗口中全范围显示
acaddoc.Save '保存地形图
acaddoc.Close '关闭地形图
End If
Next
End With
ExcelApp.Quit '关闭并退出EXCEL
End Sub
6）本程序在WINDOWS XP操作系统中的CASS 7.0和EXCEL 2003的运行环境下，运行正常并达到预期结果，此时，包括图名、测量单位、测量方法等信息的图框已加入到1:1000分幅图中，单个1:1000分幅成果图如下图（3）。
图3: 1:1000分幅成果图
4、结束语
本文介绍的程序通过对CASS和EXCEL内置的VBA开发工具的分析和利用，实现了根据索引文件自动绘制地形图图框，大大提高了工作效率和准确率。
参考文献：
1.孔祥丰等译.Auto Cad VBA从入门到精通.北京：电子工业出版社，2001.
2.邓国成，王莉，朱宏.基于VBA的Auto Cad二次开发在地质图中的应用.工程地质计算机应用，2009.
作者简介：
高化奎（1984年03月），汉族，男，学士学位，研究方向：VBA在测绘中的应用。
论文作者:高化奎
论文发表刊物:《基层建设》2016年24期8月下
论文发表时间:2016/12/5
标签：方正论文; 图名论文; 地形图论文; 坐标论文; 索引论文; 地形论文; 方法论文; 《基层建设》2016年24期8月下论文;