ExcelVBA在工程測量上的應(yīng)用

1、Excel VBA在工程測量上的應(yīng)用摘要：Excel是大家很熟悉的辦公軟件，相信大家在工作中經(jīng)常使用吧。在測量工作中，你是否感覺到有很不方便的時候？比如，計算一個角度的三角函數(shù)值，而角度的單位是60進制的，此時，你一定感到很無奈，因為，Excel本身無法直接計算60進制的角度的三角函數(shù)！還有，如果你的工作表中有了點坐標值（二維或者三維），要在CAD中展繪出來，怎樣才能又快又直接？不然，就只有拐彎摸角了，很痛苦?。∑鋵?，只要對 Excel進行一些挖掘，就可以發(fā)現(xiàn)Excel的功能我們還沒有好好的利用呢。Excel本身提供了強大的二次開發(fā)功能，只要我們仔細的研究，沒有什么能難倒我們的。下面，好好筆者

2、將帶你走近Excel，認識它的強大的二次開發(fā)環(huán)境VBAIDE，用它來解決上面所提到的問題，就非常容易了。 關(guān)鍵詞：Excel VBA 工程測量 Excel是大家很熟悉的辦公軟件，相信大家在工作中經(jīng)常使用吧。在測量工作中，你是否感覺到有很不方便的時候？比如，計算一個角度的三角函數(shù)值，而角度的單位是60進制的，此時，你一定感到很無奈，因為，Excel本身無法直接計算60進制的角度的三角函數(shù)！還有，如果你的工作表中有了點坐標值（二維或者三維），要在CAD中展繪出來，怎樣才能又快又直接？不然，就只有拐彎摸角了，很痛苦??！其實，只要對 Excel進行一些挖掘，就可以發(fā)現(xiàn)Excel的功能我們還沒有好好的利

3、用呢。Excel本身提供了強大的二次開發(fā)功能，只要我們仔細的研究，沒有什么能難倒我們的。下面，好好筆者將帶你走近Excel，認識它的強大的二次開發(fā)環(huán)境VBAIDE，用它來解決上面所提到的問題，就非常容易了。初識VBAIDE，首先，你必須懂得一些簡單的VB編程常識。如果不懂就只有通過其他的途徑去學(xué)習(xí)了。但用不著深入的研究，只要靜下心來，幾個小時就可以了。打開Excel，按Alt+F11即進入VBAIDE，學(xué)過VB的人一看就知道那就是熟悉的VB界面。下面看看如何定義一個函數(shù)，然后利用它來解決60進制的角度的三角函數(shù)計算問題。在菜單上依次點擊插入­­­

4、­->模塊，然后輸入如下代碼Public Const pi = 3ublic 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 DoubleD = Abs(n) + 0.0001F = Sgn(n)A = Int(D)B = Int(D - A) * 100)C = D - A - B / 100DEG = F * (A + B / 60

5、+ C / 0.36) * pi / 180End Function這樣，就定義了一個名字叫DEG的函數(shù)，它的作用就是轉(zhuǎn)換60進制的角度為Excel認識的弧度。編輯完后按Alt+Q即返回Excel，再在某一單元格輸入=sin(deg(A1)(A1既可以是單元格的值,也可以是輸入的角度值),回車，哈哈，怎么樣？結(jié)果出來了吧？你可以用計算器檢驗一下是否正確。如果出現(xiàn)#NAME？那就要設(shè)置一下安全設(shè)置。依次點工具->宏->安全性，在安全級選項卡上選擇“中”或者“低”，然后關(guān)閉后重新打開就可以了，以后只要是60進制的角度，就用它轉(zhuǎn)換，非常方便哦。工程測量中，經(jīng)常碰到導(dǎo)線的計

6、算，如果手頭沒有平差計算程序就只有手工計算了，這時候你曾經(jīng)想過編個小程序來計算？其實，這很簡單，筆者在宛坪（上海至武威）高速公路上做測量監(jiān)理，因為有大量的導(dǎo)線需要復(fù)核，故編寫了一個附合導(dǎo)線計算程序，代碼很簡單，但很實用。下面是該程序的代碼：Sub附合導(dǎo)線計算()Dim m As Integer, n As Integer, ms As Double, gg As Double, sht As Object, xx As Double, yy As Double, S As DoubleSet sht = ThisWorkbook.ActiveSheetDo While sht.Cells(m

7、+ 3, 4) <> ""m = m + 1LoopFor n = 3 To m + 2ms = DEG(ms) + DEG(sht.Cells(n, 4)ms = RAD(ms)S = S + sht.Cells(n, 3)Nextms = DEG(ms)gg = RAD(DEG(sht.Cells(3, 5) + ms - DEG(sht.Cells(3 + m, 5) - pi * m)xx = 0: yy = 0For n = 4 To m + 2'方位角sht.Cells(n, 5) = RAD(DEG(sht.Cells(n

8、- 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)Ne

9、xtxx = 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

10、(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

11、To m + 2sht.Cells(n, 8) = Format(xx / S * sht.Cells(n - 1, 3), "#.#")sht.Cells(n, 9) = Format(yy / S * sht.Cells(n - 1, 3), "#.#")NextFor n = 4 To m + 1sht.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

12、, 7) - sht.Cells(n, 9)Next Columns("F:K").Select Selection.NumberFormatLocal = "0.000_ "End SubPublic Function RAD(Nu As Double) As DoubleDim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, p As DoubleD = Abs(Nu)F = Sgn(Nu)p = 180# / piG

13、 = p * 60#A = Int(D * p)B = Int(D - A / p) * G)W = BC = (D - A / p - B / G) * 20.62648062RAD = (C + A + B / 100) * FEnd Function值得注意的是，前面提到的DEG函數(shù)別忘記加進去。如果自己定義一個名字叫“計算”的按鈕，指定此工具的宏為“單一附合導(dǎo)線計算”，那么，只要按下面的格式輸入原始數(shù)據(jù)（斜體是輸入的），點“計算”就可以得到計算結(jié)果了。所有的過程都是自動的，無須再手工填寫，是不是很方便？下面我們就來解決上面提到的與CAD的連接和通訊問題。進入VBAIDE，按工具-&am

14、p;gt;引用,找到可使用的引用，在“AutoCAD2000類型庫”的左邊打鉤，點確定就行了。在模塊中輸入以下代碼：Global Sheet As Object, acadmtext As acadmtext, fontHight As DoubleGlobal xlBook As Excel.WorkbookGlobal p0(2) As Double, p1(2) As Double, p2(2) As DoubleGlobal acadApp As AcadApplicationGlobal acadDoc As AcadDocumentGlobal acadPoint As acadP

15、ointGlobal number As IntegerPublic Type ptn As Integerpt(2) As DoubleGlobal pt() As ptGlobal text1 As AcadText Global CAD As Object Global p(2) As Double, i As Integer, j As Integer Global h As Integer, l As IntegerPublic Function Get_ACAD(Dwt As String) As BooleanDim YER As Integer On Error Resume

16、Next Set acadApp = GetObject(, "AutoCAD.Application") If Err Then Err.Clear Set acadApp = CreateObject("AutoCAD.Application") If Err Then MsgBox Err.Description On Error GoTo 0 Get_ACAD = False Exit Function End If End If On Error GoTo 0Set acadDoc = acadApp.ActiveDocument acadAp

17、p.Visible = True Get_ACAD = True Dim typeFace As String Dim Bold As Boolean Dim Italic As Boolean Dim charSet As Long Dim PitchandFamily As Long acadDoc.ActiveTextStyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamilyacadDoc.ActiveTextStyle.SetFont "宋體", Bold, Italic, charSet, Pitch

18、andFamilyEnd FunctionSub 顯示對話框()Form1.Show (0)End SubPublic Function Draw_Point(Point() As Double) As acadPoint Set Draw_Point = acadDoc.ModelSpace.AddPoint(Point) Draw_Point.UpdateEnd FunctionPublic Sub Set_layer(s As String) Dim layerObj As AcadLayer Set layerObj = acadDoc.Layers.Add(s) acadDoc.Ac

19、tiveLayer = layerObjEnd Sub再按以下模式做個對話框：窗體的名字就叫“Form1”雙擊“展點”按鈕，輸入以下代碼：Dim p0(2) As Double, p1(2) As Double, p2(2) As DoubleDim T1 As Double, T2 As Double, T3 As Double, T4 As DoublePublic ne As Integer, sp As Single, cz As SingleCall Get_ACAD("")Dim txt As AcadTextDim la As AcadLayerFor Eac

20、h Layer In acadDoc.ModelSpaceNextCall Set_layer("zdh")Set Sheet = ThisWorkbook.ActiveSheetDim i As IntegerDo While Sheet.Cells(i + 1, 3) <> "" Or Sheet.Cells(i + 1, 1) <> ""If Sheet.Cells(i + 1, 3) = "" Or Sheet.Cells(i + 1, 4) = &q

21、uot;" Then GoTo IIWith Sheetp1(0) = .Cells(i + 1, 3).Valuep1(1) = .Cells(i + 1, 4).Valuep1(2) = .Cells(i + 1, 5).ValueEnd Withp(0) = p1(0)p(1) = p1(1)Call Set_layer("ZDH")Call Draw_Point(p1)fontHight = TextBox5.ValueIf Cells(i + 1, 2) = "" Then GoTo ooSet txt = acadDoc.ModelSpace.AddText(Cells(i + 1, 2), p, fontHight)txt.Color = acMagent