网站公告列表 [路桥吾爱]全新改版,正在为打造一个真正属于路桥人自己并完全免费的网络空间而努力。新站启用了多线路镜像空间,让您无论使用哪种线路都能体会到不错的速度。本站继续坚持“我为人人,人人为我”的精神,鼓励大家发布并免费共享自己收藏的资料。现在加入让我们与[路桥吾爱]共同成长,有了您的加入我们会更加优秀!
 
收藏本站
会员中心
用户注册
您现在的位置: 路桥吾爱 >> 文章中心 >> 其他相关 >> 测绘 >> 文章正文
  [组图]Excel VBA在工程测量上的应用          【字体:
Excel VBA在工程测量上的应用

Excel是大家很熟悉的办公,相信大家在工作中经常使用吧。在测量工作中,你是否感觉到有很不方便的时候?比如,计算一个角度的三角函数值,而角度的单位是60进制的,此时,你一定感到很无奈,因为,Excel本身无法直接计算60进制的角度的三角函数!还有,如果你的工作表中有了点坐标值(二维或者三维),要在中展绘出来,怎样才能又快又直接?不然,就只有拐弯摸角了,很痛苦啊!其实,只要对 Excel进行一些挖掘,就可以发现Excel的功能我们还没有好好的利用呢。Excel本身提供了强大的二次开发功能,只要我们仔细的研究,没有什么能难倒我们的。下面,好好笔者将带你走近Excel,认识它的强大的二次开发环境VBAIDE,用它来解决上面所提到的问题,就非常容易了。

  初识VBAIDE,首先,你必须懂得一些简单的VB编程常识。如果不懂就只有通过其他的途径去学习了。但用不着深入的研究,只要静下心来,几个小时就可以了。

  打开Excel,按Alt+F11即进入VBAIDE,学过VB的人一看就知道那就是熟悉的VB界面。下面看看如何定义一个函数,然后利用它来解决60进制的角度的三角函数计算问题。在菜单上依次点击[插入]­­­­->[模块],然后输入如下代码

Public Const pi = 3.14159265359

Public Function DEG(n As Double)

Dim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, KA As Double

D = Abs(n) + 0.000000000000001

F = Sgn(n)

A = Int(D)

B = Int((D - A) * 100)

C = D - A - B / 100

DEG = F * (A + B / 60 + C / 0.36) * pi / 180

End Function

  这样,就定义了一个名字叫DEG的函数,它的作用就是转换60进制的角度为Excel认识的弧度。编辑完后按Alt+Q即返回Excel,再在某一单元格输入=sin(deg(A1))(A1既可以是单元格的值,也可以是输入的角度值),回车,哈哈,怎么样?结果出来了吧?你可以用计算器检验一下是否正确。如果出现#NAME?那就要设置一下安全设置。依次点[工具]->[宏]->[安全性],在安全级选项卡上选择“中”或者“低”,然后关闭后重新打开就可以了,以后只要是60进制的角度,就用它转换,非常方便哦。

  工程测量中,经常碰到导线的计算,如果手头没有平差计算程序就只有手工计算了,这时候你曾经想过编个小程序来计算?其实,这很简单,笔者在宛坪(上海至武威)高速公路上做测量监理,因为有大量的导线需要复核,故编写了一个附合导线计算程序,代码很简单,但很实用。下面是该程序的代码:

Sub附合导线计算()

Dim m As Integer, n As Integer, ms As Double, gg As Double, sht As Object, xx As Double, yy As Double, S As Double

Set sht = ThisWorkbook.ActiveSheet

Do While sht.Cells(m + 3, 4) <> ""

m = m + 1

Loop

For n = 3 To m + 2

ms = DEG(ms) + DEG(sht.Cells(n, 4))

ms = RAD(ms)

S = S + sht.Cells(n, 3)

Next

ms = DEG(ms)

gg = RAD(DEG(sht.Cells(3, 5)) + ms - DEG(sht.Cells(3 + m, 5)) - pi * m)

xx = 0: yy = 0

For n = 4 To m + 2

'方位角

sht.Cells(n, 5) = RAD(DEG(sht.Cells(n - 1, 5)) + DEG(sht.Cells(n - 1, 4)) - pi - DEG(gg) / m)

'坐标增量

sht.Cells(n, 6) = Format(sht.Cells(n - 1, 3) * Cos(DEG(sht.Cells(n, 5))), "#####.####")

sht.Cells(n, 7) = Format(sht.Cells(n - 1, 3) * Sin(DEG(sht.Cells(n, 5))), "#####.####")

'坐标增量和

xx = xx + sht.Cells(n, 6)

yy = yy + sht.Cells(n, 7)

Next

xx = xx + sht.Cells(3, 10) - sht.Cells(m + 2, 10)

yy = yy + sht.Cells(3, 11) - sht.Cells(m + 2, 11)

sht.Cells(m + 4, 5) = "△α=" & Format(gg, "###.######")

sht.Cells(m + 4, 6) = "△X=" & Format(xx, "###.###")

sht.Cells(m + 4, 7) = "△Y=" & Format(yy, "###.###")

sht.Cells(m + 4, 3) = "∑S=" & Format(S, "###.###")

sht.Cells(m + 4, 9) = "△S=" & Format(Sqr(xx * xx + yy * yy), "###.###")

sht.Cells(m + 4, 10) = "相对精度 1/" & Format(S / Sqr(xx * xx + yy * yy), "######")

For n = 4 To m + 2

sht.Cells(n, 8) = Format(xx / S * sht.Cells(n - 1, 3), "###.####")

sht.Cells(n, 9) = Format(yy / S * sht.Cells(n - 1, 3), "###.####")

Next

For n = 4 To m + 1

sht.Cells(n, 10) = sht.Cells(n - 1, 10) + sht.Cells(n, 6) - sht.Cells(n, 8)

sht.Cells(n, 11) = sht.Cells(n - 1, 11) + sht.Cells(n, 7) - sht.Cells(n, 9)

Next

    Columns("F:K").Select

    Selection.NumberFormatLocal = "0.000_ "

End Sub

Public Function RAD(Nu As Double) As Double

Dim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, p As Double

D = Abs(Nu)

F = Sgn(Nu)

p = 180# / pi

G = p * 60#

A = Int(D * p)

B = Int((D - A / p) * G)

W = B

C = (D - A / p - B / G) * 20.62648062

RAD = (C + A + B / 100) * F

End Function

  值得注意的是,前面提到的DEG函数别忘记加进去。

  如果自己定义一个名字叫“计算”的按钮,指定此工具的宏为“单一附合导线计算”,那么,只要按下面的格式输入原始数据(斜体是输入的),点“计算”就可以得到计算结果了。所有的过程都是自动的,无须再手工填写,是不是很方便?

  下面我们就来解决上面提到的与的连接和通讯问题。

  进入VBAIDE,按[工具]->[引用],找到可使用的引用,在“Auto2000类型库”的左边打钩,点确定就行了。在模块中输入以下代码:

Global Sheet As Object, amtext As amtext, fontHight As Double

 Global xlBook As Excel.Workbook

Global p0(2) As Double, p1(2) As Double, p2(2) As Double

Global aApp As AApplication

Global aDoc As ADocument

Global aPoint As aPoint

 Global number As Integer

 Public Type pt

 n As Integer

 pt(2) As Double

Global pt() As pt

 Global text1 As AText

   Global As Object

   Global p(2) As Double, i As Integer, j As Integer

      Global h As Integer, l As Integer

Public Function Get_A(Dwt As String) As Boolean

 Dim YER As Integer

    On Error Resume Next

    Set aApp = GetObject(, "Auto.Application")

    If Err Then

        Err.Clear

        Set aApp = CreateObject("Auto.Application")

        If Err Then

            MsgBox Err.Description

            On Error GoTo 0

            Get_A = False

            Exit Function

        End If

    End If

    On Error GoTo 0

Set aDoc = aApp.ActiveDocument

    aApp.Visible = True

    Get_A = True

    Dim typeFace As String

    Dim Bold As Boolean

    Dim Italic As Boolean

    Dim charSet As Long

    Dim PitchandFamily As Long

    aDoc.ActiveTextStyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily

aDoc.ActiveTextStyle.SetFont "宋体", Bold, Italic, charSet, PitchandFamily

End Function

Sub 显示对话框()

Form1.Show (0)

End Sub

Public Function Draw_Point(Point() As Double) As aPoint

    Set Draw_Point = aDoc.ModelSpace.AddPoint(Point)

    Draw_Point.Update

End Function

Public Sub Set_layer(s As String)

    Dim layerObj As ALayer

    Set layerObj = aDoc.Layers.Add(s)

    aDoc.ActiveLayer = layerObj

End Sub

再按以下模式做个对话框:窗体的名字就叫“Form1”

双击“展点”按钮,输入以下代码:

Dim p0(2) As Double, p1(2) As Double, p2(2) As Double

Dim T1 As Double, T2 As Double, T3 As Double, T4 As Double

Public ne As Integer, sp As Single, cz As Single

Call Get_A("")

Dim txt As AText

Dim la As ALayer

For Each Layer In aDoc.ModelSpace

Next

Call Set_layer("zdh")

Set Sheet = ThisWorkbook.ActiveSheet

Dim i As Integer

Do While Sheet.Cells(i + 1, 3) <> "" Or Sheet.Cells(i + 1, 1) <> ""

If Sheet.Cells(i + 1, 3) = "" Or Sheet.Cells(i + 1, 4) = "" Then GoTo II

With Sheet

p1(0) = .Cells(i + 1, 3).Value

p1(1) = .Cells(i + 1, 4).Value

p1(2) = .Cells(i + 1, 5).Value

End With

p(0) = p1(0)

p(1) = p1(1)

Call Set_layer("ZDH")

Call Draw_Point(p1)

 fontHight = TextBox5.Value

If Cells(i + 1, 2) = "" Then GoTo oo

Set txt = aDoc.ModelSpace.AddText(Cells(i + 1, 2), p, fontHight)

txt.Color = acMagenta

o

If Cells(i + 1, 5) = "" Then GoTo II

Set_layer ("GCD")

p(1) = p1(1) - fontHight

Set txt = aDoc.ModelSpace.AddText(Format(Cells(i + 1, 5), "00.0"), p, fontHight)

txt.Color = acMagenta

II:

i = i + 1

 Loop

End Sub

  当然,你在Excel上同样可以再加个工具按钮,比如叫“展点”,指定宏为“显示对话框”,只要你的Excel有了X,Y或者X,Y,Z(格式如下表),点击“展点” 就可以自动启动A uto展点啦!当然,如果A uto已经启动,就直接在已经打开的A uto文档中展点,展点完毕后,会显示一个对话框,提示“展点完毕“,再切换到A uto看看,你所要展的点是否已经出现了?如果没有输入错误,应该可以得到满意的结果。如果有点号,还可以显示点号,并且可以输入字体的高度。

  下面是坐标格式,其中第一列为点名,第二列为编码(可以为空),第三列为X,第四列为Y,第五列为高程。注意,X,Y是A uto的横坐标和纵坐标,与测量坐标系不同。

  Excel的功能是非常强大的,如果有兴趣,你还可以在Auto中直接与Excel通讯,比如一条三维多段线的所有结点的三维坐标直接导入到Excel,比在Auto中用列表的方法要方便的多,限于篇幅,无法在此详细叙述了。如果读者有兴趣,可以深入的学习和探讨。

文章录入:admin    责任编辑:admin 
  • 上一篇文章:

  • 下一篇文章:
  • 最新热点 最新推荐 相关文章
    没有相关文章
      网友评论:(只显示最新10条。评论内容只代表网友观点,与本站立场无关!)
    粤ICP备06026757号
    站长:白黑点击这里和我QQ聊天-进入[路桥吾爱]新版