利用VBA程序语言绘制铁路纵断面图

利利用用 VBA 程程序序语语言言绘绘制制 铁铁路路纵纵断断面面图图 摘摘要要 VBA 作为一个集成的开发环境 能够使AutoCAD 数据与其它的 VBA 应用程序 如 Microsoft Excel 软件 直接共享 实现无缝连接 交换数 据 本文介绍如何利用VBA 编程建立 AutoCAD2000 与 Excel2000 的通信 实现数据交换 快速绘制公路纵断面地面线 关关键键词词 公路纵断面设计 地面线 VBA AutoCAD 与 Excel 的通信 前前言言 纵断面设计图是道路纵断面设计的主要成果 也是道路设计的重要技术文件 之一 在纵断面设计图上有两条主要的线 一条是地面线 它是根据中线上各桩 点的高程而点绘的一条不规则的折线 反映了沿着中线地面的起伏变化 另一条 是设计线 它是经过技术上 经济上以及美学上等多方面比较后定出的一条规则 形状的几何线 公路设计中 在没有专业设计软件辅助的情况下 绘制公路纵断面图是很繁 琐的事 需要进行大量的 重复的操作 既劳神 又容易出错 特别在公路外业 勘测阶段 需要在短时间内将所测量的中桩高程转化成纵断面图上的地面线 才 可以进行路线纵坡设计 分析测量成果 选线 是否合理 如何快速绘制公路纵断面地面线呢 答案是 利用 Microsoft Excel AutoCAD 都提供的 VBA 功能 编制程序进行绘制 即把 Microsoft Excel 表格中的桩号 地面高程等信息读取出来 在AutoCAD 文 件里以文字 线条的方式写出来 就可绘出中桩地面线 2 VBA 简介 Visual Basic for Application VBA 是 Microsoft 面向最终用户的应用软 件编程语言 它最早出现于Microsoft 的 Excel 和 Project 中 如今 VBA 已成 为 VB 和所有 Office 产品的组件 常用的绘图软件AutoCAD 也已支持 VBA 作为二次开发工具 VBA 最大特点和最大优点是利用面向对象 OOP 的 ActiveX Automation 技术 使语言的引擎在技术上与开发环境分离 它的功能 在很大程度上依赖于它的客户显露的Automation 接口 同时 由于VBA 是 基于 ActiveX Automation 技术 它可以使用任何Automation 技术的应用程序 共同工作 基于 AutoCAD 的 VBA 应用程序就是高级程序语言的计算功能与 AutoCAD 的绘图功能结合 使用VBA 程序语句来控制对AutoCAD 图形的操 作 VBA 作为一个集成的开发环境 它提供了高质量的用户化编程能力 能够 使 AutoCAD 数据与其它的 VBA 应用程序 如 Microsoft Excel 软件 直接共 享 实现无缝连接 交换数据非常方便 3 工作机理分析 在 Microsoft Excel 中 与表对应的对象是工作表 Sheet 或 Worksheet 与每一个表格方格对应的对象是单元格区域 range 它可以仅包括一个单元 格 cell 也可以由多个单元格合并而成 工作表对象中的cells 属性 在单 元格的选择方面可以达到与range 相同的效果 它是以行 row 和列 gol 作为参数的 对于行和列的选择可以采用变量的形式 在本例中 可设 定工作表 Worksheet 的每一行第一列 cells i 1 为中桩桩号 每一行 第二列 cells i 2 为对应的地面高程 在 AutoCAD 中 没有与表对应的对象 但可以根据表中前后桩号定义水平 距离 根据地面高程定义垂直距离 将表中数据理解为线条与文字对象的集合 这样 通过读取Microsoft Excel 文件中的最小对象 单元格区域 cells i j 的主要信息 利用VBA 建立 AutoCAD 与 Excel 的通信 然后 在 AutoCAD 文件里指定的图层 位置画线条 书写文字 通过循环 遍历所有 单元格区域 cells i j 边读边写 最终完成纵断面地面线的绘制及桩号 地面高程的书写 4 具体实现方法 4 1 在 AutoCAD 中创建 Excel 应用程序 要编写存取 Excel 的应用程序 必须通过VBA 将 Excel 中的对象能够让 用户使用 这就需要参考 Excel 对象的数据库 其步骤如下 4 1 1 打开 AutoCAD 的 VBA 编辑器 命令 VBAIDE 4 1 2 选择 工具 引用 项 在弹出的 引用 对话框的 可使用的引用 列 表框内 选择 Microsoft Excel 8 0 Object Library 项 4 1 3 单击 确定 按钮 4 1 4 接下来使用下列代码可创建完整的应用程序对象实例 Dim Excel As Excel Application 激活要与之通信的Excel 应用程序 On Error Resume Next Set Excel GetObject Excel Application If Err 0 Then Set Excel CreateObject Excel Application End If 4 2 读入坐标点画地面线 4 2 1 设定工作表 Worksheet 的每一行第一列 cells i 1 为中桩 桩号 每一行第二列 cells i 2 为对应的地面高程 由于公路路线纵断面 图水平方向比例为1 2000 垂直方向比例为1 200 故读入时 y 坐标应乘以 10 倍 4 2 2 以 0 0 0 为原点 以桩号里程为x 坐标 以 10 倍所对应的 地面高程为 y 坐标 0 为 z 坐标 定义某一桩号对应的地面点坐标 然后循环 读取各里程桩号数据信息 定义各桩号所对应的地面点坐标 最后以直线段连接 各地面点坐标 则为地面线 4 2 3 下述代码可读入Excel 数据信息画地面线 Dim i As Integer Dim lineobj As AcadLine Dim sPnt 0 To 2 As Double Dim ePnt 0 To 2 As Double 读入坐标画地面线 Worksheets sheet1 Activate i 3 由第三行起 Do Until cells i 1 Value If cells i 1 1 0 Then Exit Do End If sPnt 0 cells i 1 Value sPnt 1 10 cells i 2 Value sPnt 2 0 ePnt 0 cells i 1 1 Value ePnt 1 10 cells i 1 2 Value ePnt 2 0 Set lineobj ThisDrawing ModelSpace AddLine sPnt ePnt i i 1 Loop 4 3 桩号及高程的写入 4 3 1 定义文字的插入位置 以桩号里程为 x 坐标 0 为 y 坐标 0 为 z 坐标 确定文字的插入点 4 3 2 以单行文字形式创建桩号及高程文字 定义文字的格式 字体 高度 倾斜角度 插入后的文字应逆时针旋转90 度 4 4 辅助网格线的绘制 4 4 1 辅助网格线能较为直观地表示桩号及地面高程的对应关系 有助于纵 坡设计 4 4 2 以桩号里程为 x 坐标 0 为 y 坐标 0 为 z 坐标 确定网格线第一 点 以桩号里程为x 坐标 10 倍所对应的地面高程为y 坐标 0 为 z 坐标 确定网格线第二点 两点连线 则为网格线 5 实例 5 1 运行 AutoCAD2000 程序 5 2 打开 AutoCAD 的 VBA 编辑器 命令 VBAIDE 5 3 创建成下面的过程及代码 并运行之 Sub ZDM Dim Excel As Excel Application Dim ExcelSheet As Object Dim ExcelWorkbook As Object Dim i As Integer Dim lineobj As AcadLine Dim klineobj As AcadLine Dim sPnt 0 To 2 As Double Dim ePnt 0 To 2 As Double Dim kPnt 0 To 2 As Double Dim hPnt 0 To 2 As Double Dim ksPnt 0 To 2 As Double Dim kePnt 0 To 2 As Double Dim dmPnt 0 To 2 As Double Dim textObj As AcadText Dim txtStr As String Dim insPnt As Variant Dim txtHeight As Double Dim layObj As AcadLayer Dim newLayer As AcadLayer Set layObj ThisDrawing Layers Add 标注 Set layObj ThisDrawing Layers Add 地面线 Set layObj ThisDrawing Layers Add 网格线 Dim atTxtobj As AcadTextStyle Set atTxtobj ThisDrawing ActiveTextStyle atTxtobj fontFile c windows fonts simfang ttf 创建 Excel 应用程序 On Error Resume Next Set Excel GetObject Excel Application If Err 0 Then Set Excel CreateObject Excel Application End If 打开 Excel 表 ExcelName InputBox 路径 Excel Workbooks Open ExcelName 表格不可见 Excel Visible False 读入坐标点画地面线 Worksheets sheet1 Activate i 3 Do Until cells i 1 Value If cells i 1 1 0 Then Exit Do End If sPnt 0 cells i 1 Value sPnt 1 10 cells i 2 Value sPnt 2 0 ePnt 0 cells i 1 1 Value ePnt 1 10 cells i 1 2 Value ePnt 2 0 Set newLayer ThisDrawing Layers 地面线 ThisDrawing ActiveLayer newLayer newLayer Color acWhite Set lineobj ThisDrawing ModelSpace AddLine sPnt ePnt If cells i 2 Then lineobj Delete i i 1 Loop 画辅助网格线及插入数据 i 3 Do Until cells i 1 Value 画辅助网格线 ksPnt 0 cells i 1 Value ksPnt 1 0 ksPnt 2 0 kePnt 0 cells i 1 Value kePnt 1 10 cells i 2 Value kePnt 2 0 dmPnt 0 cells i 1 Value dmPnt 1 48 dmPnt 2 0 Set newLayer ThisDrawing Layers 网格线 ThisDrawing ActiveLayer newLayer newLayer Color acGreen Set klineobj ThisDrawing ModelSpace AddLine ksPnt kePnt 插入桩号 Set newLayer ThisDrawing Layers 标注 ThisDrawing ActiveLayer newLayer newLayer Color acCyan a cells i 1 Value b Int a 1000 c Format a b 1000 000 000 d a Int a E Format c 000 000 If c 0 Then E K LTrim Str b txtStr E txtHeight 4 textObj Rotation 3 14159 2 insPnt ksPnt Set textObj ThisDrawing ModelSpace AddText txtStr insPnt txtHeight If cells i 2 Then textObj Delete 插入地面高程 txtStr Format cells i 2 Value 0 0 txtHeight 4 textObj Rotation 3 14159 2 insPnt dmPnt Set textObj ThisDrawing ModelSpace AddText txtStr insPnt txtHeight i i 1 Loop ZoomAll 该语句用来等待查看显示结果 MsgBox 按 确定 键将关闭 Excel 的运行 保存传过来的数据 ExcelWorkbook Close ExcelWorkbook Save 关闭 Excel 应用程序 Excel Application Quit 删除 Excel 应用程序实例 Set Excel Nothing End Sub 5 4 运行上述代码后 将会弹出窗口 提示输入Excel