【導讀】采用AutoCADVBA二次開發(fā)技術，實現了地表移動觀測數據處理、成圖自動一體化。克服了傳統(tǒng)方法成圖只能查看、不易定量分析的缺點。在輸出下沉、傾斜、曲率、水平。取任意點的對應值。且圖中按原比例繪出對應地下煤層開采情況，可很方便地從圖中直。接量取各角量參數，距離參數。生成的曲線圖更有利于直觀現時地分析開采對地表的影

　　

【正文】 i = LBound(brr) To UBound(brr) If brr(i) Then arr = Split(brr(i), vbTab) 安徽理工大學畢業(yè)論文 24 If UBound(arr) 5 Then dn = arr(0) wn(i) = Format(CDbl(arr(6)) CDbl(arr(3)), ) gx(i) = Format(Sqr((CDbl(arr(1)) JX1) ^ 2 + (CDbl(arr(2)) JY1) ^ 2) * Cos(a) + JX1, ) gy(i) = Format(Sqr((CDbl(arr(1)) JX1) ^ 2 + (CDbl(arr(2)) JY1) ^ 2) * Sin(a) + JY1, ) ds(i) = Format(Sqr((gx(i) JX1) ^ 2 + (gy(i) JY1) ^ 2), ) End If End If Next For j = LBound(brr) To UBound(brr) 2 wi(j) = (wn(j + 1) wn(j)) / (ds(j + 1) ds(j)) 39。mystr = mystr amp。 wi(j) amp。 vbCrLf Next For m = LBound(brr) To UBound(brr) 3 wk(m) = 2 * (wi(m + 1) wi(m)) / (ds(m + 1) + ds(m)) Next For k = 0 To UBound(brr) 3 AQ(3 * k) = ds(k + 1): AQ(3 * k + 1) = wk(k) / n: AQ(3 * k + 2) = 0 mystr = mystr amp。 AQ(3 * k) amp。 , amp。 AQ(3 * k + 1) amp。 , amp。 AQ(3 * k + 2) amp。 vbCrLf Next = mystr Dim splineObj As AcadSpline Dim startTan(0 To 2) As Double Dim endTan(0 To 2) As Double startTan(0) = 0: startTan(1) = 0: startTan(2) = 0 endTan(0) = 1500: endTan(1) = 0: endTan(2) = 0 安徽理工大學畢業(yè)論文 25 Set splineObj = (AQ, startTan, endTan) End Sub ： Private Sub CommandButton8_Click() Dim layer5 As AcadLayer Set layer5 = (水平移動曲線 ) = acYellow = layer5 Call sp Dim ws() As Double Dim AQ() As Double Dim ds() As Double Dim hs() As Double Dim gx() As Double Dim gy() As Double Dim hx() As Double Dim hy() As Double Dim n As Double Dim k As Integer n = Val() JX1 = Val() JY1 = Val() JX2 = Val() JY2 = Val() a = Atn((JY2 JY1) / (JX2 JX1)) Dim ss As String ss = Set fso = CreateObject() 安徽理工大學畢業(yè)論文 26 Set ttfile = (ss, 1) read = read = Replace(read, , ) Do While InStr(1, read, String(2, vbTab)) 0 read = Replace(read, String(2, vbTab), vbTab) Loop 39。MsgBox read brr = Split(read, vbCrLf) ReDim ws(UBound(brr)) ReDim AQ(3 * UBound(brr) 1) ReDim ds(UBound(brr)) ReDim hs(UBound(brr)) ReDim gx(UBound(brr)) ReDim gy(UBound(brr)) ReDim hx(UBound(brr)) ReDim hy(UBound(brr)) ReDim ws(UBound(brr)) For i = LBound(brr) To UBound(brr) If brr(i) Then arr = Split(brr(i), vbTab) If UBound(arr) 5 Then dn = arr(0) gx(i) = Format(Sqr((CDbl(arr(1)) JX1) ^ 2 + (CDbl(arr(2)) JY1) ^ 2) * Cos(a) + JX1, ) gy(i) = Format(Sqr((CDbl(arr(1)) JX1) ^ 2 + (CDbl(arr(2)) JY1) ^ 2) * Sin(a) + JY1, ) ds(i) = Format(Sqr((gx(i) JX1) ^ 2 + (gy(i) JY1) ^ 2), ) hx(i) = Format(Sqr((CDbl(arr(4)) JX1) ^ 2 + (CDbl(arr(5)) JY1) ^ 2) * Cos(a) + JX1, ) 安徽理工大學畢業(yè)論文 27 hy(i) = Format(Sqr((CDbl(arr(4)) JX1) ^ 2 + (CDbl(arr(5)) JY1) ^ 2) * Sin(a) + JY1, ) hs(i) = Format(Sqr((hx(i) JX1) ^ 2 + (hy(i) JY1) ^ 2), ) ws(i) = hs(i) ds(i) End If End If Next For k = 0 To UBound(brr) 1 AQ(3 * k) = ds(k): AQ(3 * k + 1) = ws(k) / n: AQ(3 * k + 2) = 0 mystr = mystr amp。 AQ(3 * k) amp。 , amp。 AQ(3 * k + 1) amp。 , amp。 AQ(3 * k + 2) amp。 vbCrLf Next = mystr Dim splineObj As AcadSpline Dim startTan(0 To 2) As Double Dim endTan(0 To 2) As Double startTan(0) = 0: startTan(1) = 0: startTan(2) = 0 endTan(0) = 1500: endTan(1) = 0: endTan(2) = 0 Set splineObj = (AQ, startTan, endTan) End Sub ： Private Sub CommandButton9_Click() Dim layer6 As AcadLayer Set layer6 = (水平變形曲線 ) = 20 = layer6 Call bx Dim ws() As Double Dim AQ() As Double Dim ds() As Double 安徽理工大學畢業(yè)論文 28 Dim hs() As Double Dim gx() As Double Dim gy() As Double Dim hx() As Double Dim hy() As Double Dim n As Double Dim k As Integer Dim j As Integer Dim we() As Double n = Val() JX1 = Val() JY1 = Val() JX2 = Val() JY2 = Val() a = Atn((JY2 JY1) / (JX2 JX1)) Dim ss As String ss = Set fso = CreateObject() Set ttfile = (ss, 1) read = read = Replace(read, , ) Do While InStr(1, read, String(2, vbTab)) 0 read = Replace(read, String(2, vbTab), vbTab) Loop 39。MsgBox read brr = Split(read, vbCrLf) ReDim ws(UBound(brr)) ReDim we(UBound(brr) 1) 安徽理工大學畢業(yè)論文 29 ReDim AQ(3 * UBound(brr) 1) ReDim ds(UBound(brr)) ReDim hs(UBound(brr)) ReDim gx(UBound(brr)) ReDim gy(UBound(brr)) ReDim hx(UBound(brr)) ReDim hy(UBound(brr)) ReDim ws(UBound(brr)) For i = LBound(brr) To UBound(brr) If brr(i) Then arr = Split(brr(i), vbTab) If UBound(arr) 5 Then dn = arr(0) gx(i) = Format(Sqr((CDbl(arr(1)) JX1) ^ 2 + (CDbl(arr(2)) JY1) ^ 2) * Cos(a) + JX1, ) gy(i) = Format(Sqr((CDbl(arr(1)) JX1) ^ 2 + (CDbl(arr(2)) JY1) ^ 2) * Sin(a) + JY1, ) ds(i) = Format(Sqr((gx(i) JX1) ^ 2 + (gy(i) JY1) ^ 2), ) hx(i) = Format(Sqr((CDbl(arr(4)) JX1) ^ 2 + (CDbl(arr(5)) JY1) ^ 2) * Cos(a) + JX1, ) hy(i) = Format(Sqr((CDbl(arr(4)) JX1) ^ 2 + (CDbl(arr(5)) JY1) ^ 2) * Sin(a) + JY1, ) hs(i) = Format(Sqr((hx(i) JX1) ^ 2 + (hy(i) JY1) ^ 2), ) ws(i) = hs(i) ds(i) End If End If Next For j = LBound(brr) To UBound(brr) 1 we(j) = (ws(j + 1) ws(j)) / (ds(j + 1) ds(j)) 39。mystr = mystr amp。 wi(j) amp。 vbCrLf 安徽理工大學畢業(yè)論文 30 Next For k = 0 To UBound(brr) 1 AQ(3 * k) = ds(k): AQ(3 * k + 1) = we(k) / n + 20xx: AQ(3 * k + 2) = 0 mystr = mystr amp。 AQ(3 * k) amp。 , amp。 AQ(3 * k + 1) amp。 , amp。 AQ(3 * k + 2) amp。 vbCrLf Next = mystr Dim splineObj As AcadSpline Dim startTan(0 To 2) As Double Dim endTan(0 To 2) As Double startTan(0) = 0: startTan(1) = 0: startTan(2) = 0 endTan(0) = 1500: endTan(1) = 0: endTan(2) = 0 Set splineObj = (AQ, startTan, endTan) End Sub 之后，將 單位一致的 變形 量繪在同一坐標