VBA的二次开发在工程测绘中的应用

ＶＢＡ的二次开发在工程测绘中的应用
［摘要］本文主要阐述了利用WORD VBA(Visual Basic for Applications)开发应用于工程测绘软件的思路和方法。

［关键字］VBA AUTOCAD 动态链接库
一、前言
在工程测绘内业处理过程中常需对WORD表格数据、AUTOCAD图形数据进行交换处理，原手工编辑方法不仅工作效率低，且易出现人为错误。

结合日常工作需要，笔者对WORD、AUTOCAD自身编程语言VBA的功能进行了二次开发，利用VBA编写的宏自动地实现了WORD表格数据与CAD图形数据的转换，既提高了工作效率，减轻了技术人员的劳动强度，又提升了工程测绘的数字化作业水平。

二、利用word的VBA进行二次开发
用WORD VBA编写宏自动实现控制点坐标（表格数据）在CAD中展点、转换成.coo（.cor）文件等功能。

然后再利用WORD的新建工具栏，将相关功能加入到工具栏中。

（一）基本功能
1、在CAD中展点
将表格数据直接转换成CAD图形数据
2、将word表格数据转换成测量常用文件（*.COO、*.COR）
（二）实现步骤
1、引用ACAD2000动态链接库（acad.tlb）。

2、在程序中定义对象
Dim acadObj As AcadApplication …定义对象
Dim jzpoint As AcadPoint …定义点对象
Dim mylayer As AcadLayer …定义图层对象
3、利用GetObject（）或CreateObject（）命令直接调用CAD
4、在cad中增加图层（Layers.Add）
5、读入表格中数据
6、展点
---三维点坐标转换成.cor文件演示程序如下：
Sub 三维点转cor()‟
Dim i As Integer
Dim xyz(2) As Double …用于存放点的X、Y、Z坐标
Dim mystr As String …用于图层名
Dim fso As FileSystemObject
Dim fl As TextStream
i = 0
z = 0
mystr = InputBox(“请输入文件名”, “提示”)
mystr = “c:\” & mystr + “.cor”
Set f so = CreateObject(“Scripting.FileSystemObject”)
Set fl = fso.OpenTextFile(mystr, ForAppending, True)
For Each c In Selection.Cells
If i = 0 Then
textstr = Trim(c.Range)‟读入点号
textstr = Left(textstr, Len(textstr) - 2)
ElseIf i = 1 Then
xyz(1) = Val(c.Range) …读入X坐标
ElseIf i = 2 Then
xyz(0) = Val(c.Range)‟读入Y坐标
ElseIf i = 3 Then
xyz(2) = Val(c.Range)‟读入Z坐标
…
z = z + 1
fl.WriteLine z & “,” & textstr & “,” & “ “ & “,” & xyz(1) & “,” & xyz(0) & “,” & xyz(2)
i = -1
End If
i = i + 1
Next c
Set fl = Nothing
Set fso = Nothing
End Sub
三、利用AUTOCAD的VBA进行二次开发
用AUTOCAD VBA编写宏命令实现图形数据文件自动生成WORD表格文档。

（一）基本功能
1、在AUTOCAD中捕捉点，生成WORD表格文档
2、图形数据转换成测量常用文件（*.COO、*.COR）
（二）实现步骤
1、引用ACAD2000动态链接库（acad.tlb）。

2、在程序中定义对象
Dim mywrd As word.Application …定义对象
Dim 成果表As Word.Document …定义文档对象
Dim mytable As Table …定义表格对象
3、利用GetObject（）或CreateObject（）命令直接调用WORD
4、在WORD中增加文档（Applicationwd .Documents.Add）同时进行页面设置
5、在文档中生成表格（Tables.Add）同时进行表格大小设置
6、读取点坐标写至word表格中。

程序附下：
将坐标文件转换成word表格
Public Sub readcoortoword()
Dim mywrd As word.Application
Dim 成果表As Word.Document
Dim mytable As Table
Dim mypoint As Variant
Dim result As String
Dim sumofpoint as Integer
Set Applicationwd = CreateObject(“Word.Application”) Applicationwd.Visible = True
With Applicationwd
Set成果表= .Documents.Add
With .Selection.PageSetup’进行页面设置
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2.5)
.BottomMargin = CentimetersToPoints(2.5)
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(1.5)
.PageWidth = CentimetersToPoints(19.5)
.PageHeight = CentimetersToPoints(27.5)
End With
With .Selection
.ParagraphFormat.Alignment = wdAlignParagraphCenter .Font.Size = 12
.Font.N ame = “楷体_GB2312”
.Tables.Add Range:=.Range, NumRows:=40, NumColumns:=4, DefaultTableBehavior:=wdword9tabelbehavior, AutoFitBehavior:=wdAutoFitFixed .Move Unit:=wdColumn, Count:=1’以下进行表格大小设置
.SelectColumn
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(1.5)
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(4)
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(4)
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = CentimetersToPoints(4)
End With
End With
Set aTable = ActiveDocument.Tables(1)
aTable.Cell(1, 1).Select
sumofpoint＝1
ThisDrawing.Utility.InitializeUserInput 0, “ C E “
result = ThisDrawing.Utility.GetKeyword(vbCrLf & “请输入一个选项（继续（c）/结束（e）”)
Select Case result
Cas e “C”
mypoint = ThisDrawing.Utility.GetPoint(, vbCrLf & “请选择点”)
Applicationwd.Selection.Range.InsertAfter sumofpoint
Applicationwd.Selection.MoveRight Unit:=wdCell
Applicationwd.Selection.Range.InsertAfter mypoint(1)
Applicationwd.Selection.MoveRight Unit:=wdCell
Applicationwd.Selection.Range.InsertAfter mypoint(0)
Applicationwd.Selection.MoveRight Unit:=wdCell
Applicationwd.Selection.Range.InsertAfter mypoint(2)
Applicationwd.Selection.MoveRight Unit:=wdCell
sumofpoint = sumofpoint + 1
Case “E”
Exit Do
Case ““
mypoint = ThisDrawing.Utility.GetPoint(, vbCrLf & “请选择点”)
Applicationwd.Selection.Range.InsertAfter sumofpoint
Applicationwd.Selection.MoveRight Unit:=wdCell
Applicationwd.Selection.Range.InsertAfter mypoint(1)
Applicationwd.Selection.MoveRight Unit:=wdCell
Applicationwd.Selection.Range.InsertAfter mypoint(0)
Applicationwd.Selection.MoveRight Unit:=wdCell
Applicationwd.Selection.Range.InsertAfter mypoint(2)
Applicationwd.Selection.MoveRight Unit:=wdCell
sumofpoint = sumofpoint + 1
End Select
Loop While True
End Sub
四、小结
VBA的功能非常强大，应用范围也很广泛，通过VBA实现WORD与AUTOCAD的直接通讯，使用很方便。

笔者结合规划编制、规划审批管理工作的需要，也进行了其它一些有益的尝试，在此不再详述。