【正文】 立基于遺傳算法的改進(jìn) BP 神經(jīng)網(wǎng)絡(luò)開(kāi)采沉陷預(yù)測(cè)模型，利安徽理工大學(xué)畢業(yè)論文 4 用礦區(qū)大量的地表沉陷實(shí)際觀測(cè)數(shù)據(jù)樣本對(duì)該神經(jīng)網(wǎng)絡(luò)進(jìn)行訓(xùn)練和學(xué)習(xí)，并用該網(wǎng)絡(luò)對(duì)幾組數(shù)據(jù)進(jìn)行采動(dòng)地表沉陷預(yù)測(cè)，改進(jìn)的 BP 神經(jīng)網(wǎng)路具有收斂速度快、預(yù)測(cè)參數(shù)精度高的優(yōu)點(diǎn)等 [15]。 對(duì) AutoCAD 進(jìn)行二次開(kāi)發(fā)，應(yīng)用 VBA 計(jì)算出各觀測(cè)點(diǎn)的各期移動(dòng)變形值，各種變形曲線(xiàn)依不同比例在 CAD 中成圖，且對(duì)應(yīng)繪出地下煤層采動(dòng)情況。 圖 1 坐標(biāo)規(guī)劃示意圖 設(shè)點(diǎn) JZ JZ2 的坐標(biāo)為（ x1， y1），（ x2， y2）， N、 n坐標(biāo)為（ x， y）、（ x’ ， y’ ）。 移動(dòng)和變形的計(jì)算 觀測(cè)數(shù)據(jù)經(jīng)規(guī)劃后，便可計(jì)算觀測(cè)線(xiàn)上各測(cè)點(diǎn)和測(cè)點(diǎn)間的移動(dòng)和變形。 安徽理工大學(xué)畢業(yè)論文 9 3 軟件實(shí)現(xiàn) AutoCAD VBA 簡(jiǎn)介 VBA ( visual basic for application) 是由 Microsoft 創(chuàng)建的，用來(lái)自動(dòng)執(zhí)行任務(wù)的一個(gè)編程環(huán)境，它提供了一些用來(lái)創(chuàng)建圖 形用戶(hù)界面的可拖拉工具和用來(lái)與AutoCAD 對(duì)象交換的編程語(yǔ)言 [5]。 計(jì)算 觀測(cè)線(xiàn) 方向代碼如下： 39。 曲線(xiàn)圖的繪制 首先依原比例繪出煤層采動(dòng)信息，及煤層與測(cè)點(diǎn)的空間關(guān)系。 定義實(shí)體 point1(0) = SKQ: point1(1) = HZ CH: point1(2) = 0 point2(0) = SKQ + ZD: point2(1) = HZ CH: point2(2) = 0 point3(0) = SKQ: point3(1) = HZ: point3(2) = 0 point4(0) = SKQ + ZD: point4(1) = HZ: point4(2) = 0 39。 定義實(shí)體 point1(0) = Q: point1(1) = HZ + Q * Tan(j * / 180): point1(2) = 0 point2(0) = Q + D * Cos(j * / 180): point2(1) = HZ + Q * Tan(j * / 180) + D * Sin(j * / 180): point2(2) = 0 point4(0) = Q + D * Cos(j * / 180): point4(1) = HZ + Q * Tan(j * / 180) + D * Sin(j * / 180) CH / Cos(j * / 180): point4(2) = 0 point3(0) = Q: point3(1) = HZ + Q * Tan(j * / 180) CH / Cos(j * / 180): point3(2) = 0 39。 vbCrLf End If End If Next For k = LBound(brr) To UBound(brr) 1 AQ(3 * k) = ds(k): AQ(3 * k + 1) = wn(k) / n: AQ(3 * k + 2) = 0 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) 安徽理工大學(xué)畢業(yè)論文 20 End Sub ： Private Sub CommandButton6_Click() Dim layer3 As AcadLayer Set layer3 = (傾斜曲線(xiàn) ) = acBlue = layer3 Call qxqx Dim wn() As Double Dim wi() As Double Dim AQ() As Double Dim ds() As Double Dim gx() As Double Dim gy() As Double Dim n As Double Dim j 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() Set ttfile = (ss, 1) read = read = Replace(read, , ) 安徽理工大學(xué)畢業(yè)論文 21 Do While InStr(1, read, String(2, vbTab)) 0 read = Replace(read, String(2, vbTab), vbTab) Loop brr = Split(read, vbCrLf) ReDim wn(UBound(brr)) ReDim AQ(3 * UBound(brr) 4) ReDim ds(UBound(brr)) ReDim gx(UBound(brr)) ReDim gy(UBound(brr)) ReDim wi(UBound(brr) 1) For i = LBound(brr) To UBound(brr) If brr(i) Then arr = Split(brr(i), vbTab) 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)) Next For k = 0 To UBound(brr) 2 安徽理工大學(xué)畢業(yè)論文 22 AQ(3 * k) = (ds(k + 1) + ds(k)) / 2: AQ(3 * k + 1) = wi(k) / n + 20xx: AQ(3 * k + 2) = 0 mystr = mystr amp。mystr = mystr 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 安徽理工大學(xué)畢業(yè)論文 25 Set splineObj = (AQ, startTan, endTan) End Sub ： Private Sub CommandButton8_Click() Dim layer5 As AcadLayer Set layer5 = (水平移動(dòng)曲線(xiàn) ) = 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() 安徽理工大學(xué)畢業(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 we(UBound(brr) 1) 安徽理工大學(xué)畢業(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。 AQ(3 * k + 2) amp。 wi(j) amp。 AQ(3 * k) 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。 , amp。MsgBox read brr = Split(read, vbCrLf) ReDi