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

1、利用 VBA 程序语言绘制铁路纵断面图摘 要 :VBA 作 为 一 个 集 成 的 开 发 环 境 , 能 够 使 AutoCAD 数 据 与 其 它 的 VBA 应 用 程 序 ,如 Microsoft Excel软 件 ,直 接 共 享 ,实 现 无 缝 连 接 ,交 换 数 据 。 本 文 介 绍 如 何 利 用 VBA 编 程 建 立 AutoCAD2000与 Excel2000的 通 信 , 实 现 数 据 交 换 , 快 速 绘 制 公 路 纵 断 面 地 面 线 。关 键 词 :公 路 纵 断 面 设 计 地 面 线 VBA AutoCAD与 Excel 的 通 信前 言纵 断

2、面 设 计 图 是 道 路 纵 断 面 设 计 的 主 要 成 果 , 也 是 道 路 设 计 的 重 要 技 术 文 件 之 一 。 在 纵 断 面 设 计 图 上 有 两 条 主 要 的 线 :一 条 是 地 面 线 , 它 是 根 据 中 线 上 各 桩 点 的 高 程 而 点 绘 的 一 条 不 规 则 的 折 线 , 反 映 了 沿 着 中 线 地 面 的 起 伏 变 化 ; 另 一 条 是 设 计 线 , 它 是 经 过 技 术 上 、 经 济 上 以 及 美 学 上 等 多 方 面 比 较 后 定 出 的 一 条 规 则 形 状 的 几 何 线 。公 路 设 计 中 , 在 没

3、有 专 业 设 计 软 件 辅 助 的 情 况 下 , 绘 制 公 路 纵 断 面 图 是 很 繁 琐 的 事 , 需 要 进 行 大 量 的 、 重 复 的 操 作 , 既 劳 神 , 又 容 易 出 错 。 特 别 在 公 路 外 业 勘 测 阶 段 , 需 要 在 短 时 间 内 将 所 测 量 的 中 桩 高 程 转 化 成 纵 断 面 图 上 的 地 面 线 , 才 可 以 进 行 路 线 纵 坡 设 计 , 分 析 测 量 成 果 (选 线 是 否 合 理 。 如 何 快 速 绘 制 公 路 纵 断 面 地 面 线 呢 ? 答 案 是 :利 用 Microsoft Excel、 A

4、utoCAD 都 提 供 的 VBA 功 能 , 编 制 程 序 进 行 绘 制 , 即 把 Microsoft Excel表 格 中 的 桩 号 、地 面 高 程 等 信 息 读 取 出 来 ,在 AutoCAD 文 件 里 以 文 字 、线 条 的 方 式 写 出 来 , 就 可 绘 出 中 桩 地 面 线 。2、 VBA 简 介Visual Basic for Application(VBA 是 Microsoft 面 向 最 终 用 户 的 应 用 软 件 编 程 语 言 。它 最 早 出 现 于 Microsoft 的 Excel 和 Project 中 ,如 今 VBA 已 成 为

5、 VB 和 所 有 Office 产 品 的 组 件 。 常 用 的 绘 图 软 件 AutoCAD 也 已 支 持 VBA 作 为 二 次 开 发 工 具 。VBA 最 大 特 点 和 最 大 优 点 是 利 用 面 向 对 象 (OOP 的 ActiveX Automation技 术 , 使 语 言 的 引 擎 在 技 术 上 与 开 发 环 境 分 离 。 它 的 功 能 在 很 大 程 度 上 依 赖 于 它 的 客 户 显 露 的 Automation 接 口 。 同 时 , 由 于 VBA 是 基 于 ActiveX Automation技 术 , 它 可 以 使 用 任 何 Au

6、tomation 技 术 的 应 用 程 序 共 同 工 作 。基 于 AutoCAD 的 VBA 应 用 程 序 就 是 高 级 程 序 语 言 的 计 算 功 能 与 AutoCAD 的 绘 图 功 能 结 合 ,使 用 VBA 程 序 语 句 来 控 制 对 AutoCAD 图 形 的 操 作 。VBA 作 为 一 个 集 成 的 开 发 环 境 ,它 提 供 了 高 质 量 的 用 户 化 编 程 能 力 ,能 够 使 AutoCAD 数 据 与 其 它 的 VBA 应 用 程 序 , 如 Microsoft Excel软 件 , 直 接 共 享 , 实 现 无 缝 连 接 , 交 换

7、 数 据 非 常 方 便 。3、 工 作 机 理 分 析在 Microsoft Excel中 , 与 表 对 应 的 对 象 是 工 作 表 (Sheet 或 Worksheet , 与 每 一 个 表 格 方 格 对 应 的 对 象 是 单 元 格 区 域 (range , 它 可 以 仅 包 括 一 个 单 元 格(cell ,也 可 以 由 多 个 单 元 格 合 并 而 成 。工 作 表 对 象 中 的 cells 属 性 ,在 单 元 格 的 选 择 方 面 可 以 达 到 与 range 相 同 的 效 果 , 它 是 以 行(row 和 列 (gol 作 为 参 数 的 , 对

8、于 行 和 列 的 选 择 可 以 采 用 变 量 的 形 式 。 在 本 例 中 , 可 设 定 工 作 表 (Worksheet 的 每 一 行 第 一 列 (cells (i,1 为 中 桩 桩 号 , 每 一 行 第 二 列 (cells (i,2 为 对 应 的 地 面 高 程 。在 AutoCAD 中 ,没 有 与 表 对 应 的 对 象 ,但 可 以 根 据 表 中 前 后 桩 号 定 义 水 平 距 离 , 根 据 地 面 高 程 定 义 垂 直 距 离 , 将 表 中 数 据 理 解 为 线 条 与 文 字 对 象 的 集 合 。 这 样 , 通 过 读 取 Microsof

9、t Excel文 件 中 的 最 小 对 象 单 元 格 区 域 (cells (i,j 的 主 要 信 息 , 利 用 VBA 建 立 AutoCAD 与 Excel 的 通 信 , 然 后 在 AutoCAD 文 件 里 指 定 的 图 层 、 位 置 画 线 条 , 书 写 文 字 。 通 过 循 环 , 遍 历 所 有 单 元 格 区 域 (cells (i,j , 边 读 边 写 , 最 终 完 成 纵 断 面 地 面 线 的 绘 制 及 桩 号 、 地 面 高 程 的 书 写 。4、 具 体 实 现 方 法4.1 在 AutoCAD 中 创 建 Excel 应 用 程 序要 编 写

10、 存 取 Excel 的 应 用 程 序 , 必 须 通 过 VBA 将 Excel 中 的 对 象 能 够 让 用 户 使 用 , 这 就 需 要 参 考 Excel对 象 的 数 据 库 。 其 步 骤 如 下 :4.1.1 打 开 AutoCAD 的 VBA 编 辑 器 (命 令 :VBAIDE ;4.1.2 选 择 “ 工 具 ” “ 引 用 ” 项 , 在 弹 出 的 “ 引 用 ” 对 话 框 的 “ 可 使 用 的 引 用 ” 列 表 框 内 , 选 择 “Microsof t Excel 8.0 Object Library” 项 ;4.1.3 单 击 “ 确 定 ” 按 钮

11、;4.1.4 接 下 来 使 用 下 列 代 码 可 创 建 完 整 的 应 用 程 序 对 象 实 例 :Dim Excel As Excel.Application' 激 活 要 与 之 通 信 的 Excel 应 用 程 序On Error Resume NextSet Excel = GetObject(, "Excel.Application"If Err <> 0 ThenSet Excel = CreateObject("Excel.Application"End If4.2 读 入 坐 标 点 画 地 面 线4.2.1

12、 设 定 工 作 表(Worksheet 的 每 一 行 第 一 列(cells (i,1 为 中 桩 桩 号 ,每 一 行 第 二 列(cells (i,2 为 对 应 的 地 面 高 程 。由 于 公 路 路 线 纵 断 面 图 水 平 方 向 比 例 为 1:2000,垂 直 方 向 比 例 为 1:200,故 读 入 时 , y 坐 标 应 乘 以 10倍 。4.2.2 以(0, 0, 0为 原 点 ,以 桩 号 里 程 为 x 坐 标 ,以 10倍 所 对 应 的 地 面 高 程 为 y 坐 标 , 0为 z 坐 标 ,定 义 某 一 桩 号 对 应 的 地 面 点 坐 标 ;然 后

13、 循 环 读 取 各 里 程 桩 号 数 据 信 息 , 定 义 各 桩 号 所 对 应 的 地 面 点 坐 标 ; 最 后 以 直 线 段 连 接 各 地 面 点 坐 标 , 则 为 地 面 线 。4.2.3 下 述 代 码 可 读 入 Excel 数 据 信 息 画 地 面 线Dim i As IntegerDim lineobj As AcadLineDim sPnt(0 To 2 As DoubleDim ePnt(0 To 2 As Double 读 入 坐 标 画 地 面 线Worksheets("sheet1".Activatei = 3 由 第 三 行 起D

14、o Until cells(i, 1.Value = ""If cells(i + 1, 1 = 0 ThenExit DoEnd IfsPnt(0 = cells(i, 1.ValuesPnt(1 = 10 * cells(i, 2.ValuesPnt(2 = 0ePnt(0 = cells(i + 1, 1.ValueePnt(1 = 10 * cells(i + 1, 2.ValueePnt(2 = 0Set lineobj = ThisDrawing.ModelSpace.AddLine(sPnt, ePnti = i + 1Loop4.3 桩 号 及 高 程 的

15、写 入4.3.1 定 义 文 字 的 插 入 位 置 以 桩 号 里 程 为 x 坐 标 , 0为 y 坐 标 , 0为 z 坐 标 , 确 定 文 字 的 插 入 点 。4.3.2 以 单 行 文 字 形 式 创 建 桩 号 及 高 程 文 字 ,定 义 文 字 的 格 式 、字 体 、高 度 、 倾 斜 角 度 。 插 入 后 的 文 字 应 逆 时 针 旋 转 90度 。4.4 辅 助 网 格 线 的 绘 制4.4.1 辅 助 网 格 线 能 较 为 直 观 地 表 示 桩 号 及 地 面 高 程 的 对 应 关 系 , 有 助 于 纵 坡 设 计 ;4.4.2 以 桩 号 里 程 为

16、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.ApplicationDim Ex

17、celSheet As ObjectDim ExcelWorkbook As ObjectDim i As IntegerDim lineobj As AcadLineDim klineobj As AcadLineDim sPnt(0 To 2 As DoubleDim ePnt(0 To 2 As DoubleDim kPnt(0 To 2 As DoubleDim hPnt(0 To 2 As DoubleDim ksPnt(0 To 2 As DoubleDim kePnt(0 To 2 As DoubleDim dmPnt(0 To 2 As DoubleDim textObj As

18、 AcadTextDim txtStr As StringDim insPnt As VariantDim txtHeight As DoubleDim layObj As AcadLayerDim newLayer As AcadLayerSet layObj = ThisDrawing.Layers.Add("标 注 "Set layObj = ThisDrawing.Layers.Add("地 面 线 "Set layObj = ThisDrawing.Layers.Add("网 格 线 "Dim atTxtobj As Aca

19、dTextStyleSet atTxtobj = ThisDrawing.ActiveTextStyle atTxtobj.fontFile = "c:windowsfontssimfang.ttf"' 创 建 Excel 应 用 程 序On Error Resume NextSet Excel = GetObject(, "Excel.Application"If Err <> 0 ThenSet Excel = CreateObject("Excel.Application"End If' 打 开 Ex

20、cel 表ExcelName = InputBox("路 径 :"Excel.Workbooks.Open ExcelName' 表 格 不 可 见Excel.Visible = False' 读 入 坐 标 点 画 地 面 线Worksheets("sheet1".Activatei = 3Do Until cells(i, 1.Value = ""If cells(i + 1, 1 = 0 ThenExit DoEnd IfsPnt(0 = cells(i, 1.ValuesPnt(1 = 10 * cells(i

21、, 2.ValuesPnt(2 = 0ePnt(0 = cells(i + 1, 1.ValueePnt(1 = 10 * cells(i + 1, 2.ValueePnt(2 = 0Set newLayer = ThisDrawing.Layers("地 面 线 " ThisDrawing.ActiveLayer = newLayernewLayer.Color = acWhiteSet lineobj = ThisDrawing.ModelSpace.AddLine(sPnt, ePnt If cells(i, 2 = "" Then lineobj

22、.Deletei = i + 1Loop' 画 辅 助 网 格 线 及 插 入 数 据i = 3Do Until cells(i, 1.Value = ""'画 辅 助 网 格 线ksPnt(0 = cells(i, 1.Value: ksPnt(1 = 0: ksPnt(2 = 0kePnt(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 = 0Set newLayer =

23、 ThisDrawing.Layers("网 格 线 "ThisDrawing.ActiveLayer = newLayernewLayer.Color = acGreenSet klineobj = ThisDrawing.ModelSpace.AddLine(ksPnt, kePnt' 插 入 桩 号Set newLayer = ThisDrawing.Layers("标 注 "ThisDrawing.ActiveLayer = newLayernewLayer.Color = acCyana = cells(i, 1.Valueb = In

24、t(a / 1000c = Format(a - b * 1000, "000.000"'d = a - Int(aE = "+" + Format(c, "000.000"If c = 0 Then E = "K" + LTrim(Str(btxtStr = EtxtHeight = 4textObj.Rotation = 3.14159 / 2insPnt = ksPntSet textObj = ThisDrawing.ModelSpace.AddText(txtStr, insPnt, txtHeight If cells(i, 2 = "" Then textObj.Delete' 插 入 地 面 高 程txtStr = Format(cells(i, 2.Value, "#0.#0"txtHeight = 4textObj.Rotation = 3.141