《导线平差12051.doc》由会员分享，可在线阅读，更多相关《导线平差12051.doc（9页珍藏版）》请在金锄头文库上搜索。
1、Sub 单一附合导线平差计算() Dim sel_R As String UserForm2.ShowEnd SubPrivate Sub CommandButton1_Click()Private Sub CommandButton2_Click() Dim STR1 As String Dim STR2 As String For i = 2 To 60 Step 2 STR1 = A + CStr(i) STR2 = A + CStr(i + 1) Call CELL_HB(STR1, STR2) STR1 = B + CStr(i) STR2 = B + CStr(i + 1) Cal
2、l CELL_HB(STR1, STR2) STR1 = C + CStr(i) STR2 = C + CStr(i + 1) Call CELL_HB(STR1, STR2) STR1 = J + CStr(i) STR2 = J + CStr(i + 1) Call CELL_HB(STR1, STR2) STR1 = K + CStr(i) STR2 = K + CStr(i + 1) Call CELL_HB(STR1, STR2) STR1 = D + CStr(i + 1) STR2 = D + CStr(i + 2) Call CELL_HB(STR1, STR2) STR1 =
3、 E + CStr(i + 1) STR2 = E + CStr(i + 2) Call CELL_HB(STR1, STR2) STR1 = F + CStr(i + 1) STR2 = F + CStr(i + 2) Call CELL_HB(STR1, STR2) STR1 = G + CStr(i + 1) STR2 = G + CStr(i + 2) Call CELL_HB(STR1, STR2) STR1 = H + CStr(i + 1) STR2 = H + CStr(i + 2) Call CELL_HB(STR1, STR2) STR1 = I + CStr(i + 1)
4、 STR2 = I + CStr(i + 2) Call CELL_HB(STR1, STR2) Next End SubPublic Sub CELL_FJ(CELL_ALL As String) Macro4 Macro 宏由 hgq 录制，时间: 2009-7-30 Range(CELL_ALL).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentL
5、evel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Selection.UnMergeEnd SubPrivate Sub CommandButton1_Click() Dim i As Integer Dim N As Integer Dim x1 As Double Dim y1 As Double Dim x2 As Double Dim y2 As Double Dim x3 As Double Dim y3 As Double Dim x4 As Double Dim
6、y4 As Double Dim f1 As Double Dim f2 As Double Dim f1_g As Double Dim f2_g As Double Dim g, ss As Double Dim f As Double Dim pi As Double Dim DF, DDF As Double Dim DX, DY, X, Y, DDX, DDY As Double Dim CELL_ALL As String Dim CELL1 As String Dim CELL2 As String Dim STR1, STR2 As String Dim S As Double
7、 Dim DX0, DY0 As Double pi = 3.141592654 i = 2 x1 = Cells(i, 10) y1 = Cells(i, 11) x2 = Cells(i + 2, 10) y2 = Cells(i + 2, 11) Call xy_rf(x1, y1, x2, y2) f1 = fxjs0 f1_g = dms(f1 * 180 / pi) DX = x2 - x1: DY = y2 - y1 S = Sqr(DX * DX + DY * DY) Cells(3, 4) = s 起算边边长 Cells(3, 5) = f1_g 起算边方位角 S = Cel
8、ls(6, 3) f = f1: i = 2: g = 100: N = 0 While i 0 i = i + 2 g = deg(Cells(i, 2) * pi / 180 If g 0 Then N = N + 1 If f = pi Then f = f - pi Else f = f + pi End If f = f + g If f 2 * pi Then f = f - 2 * pi End If End If Wend i = i - 2 x3 = Cells(i, 10): y3 = Cells(i, 11) x4 = Cells(i + 2, 10): y4 = Cel
9、ls(i + 2, 11) Call xy_rf(x3, y3, x4, y4) f2 = fxjs0 DF = f2 - f If DF pi Then DF = DF - 2 * pi Else If DF = pi Then f = f - pi Else f = f + pi End If f = f + g + DDF If f 2 * pi Then f = f - 2 * pi End If Cells(j + 1, 5) = dms(f * 180 / pi) DX = S * Cos(f): DY = S * Sin(f) Cells(j + 1, 6) = DX: Cell
10、s(j + 1, 7) = DY X = X + DX: Y = Y + DY Next Cells(i, 3) = DDF * 206265 DX = x3 - X: DY = y3 - Y: DDX = DX / ss: DDY = DY / ss DX0 = DX: DY0 = DY X = x2: Y = y2 For j = 6 To i Step 2 S = Cells(j - 1, 4) DX = Cells(j - 1, 6) + DDX * S: DY = Cells(j - 1, 7) + DDY * S X = X + DX: Y = Y + DY Cells(j - 1, 8) = DDX * S: Cells(j - 1, 9) = DDY * S If j i Then Cells(j, 10) = X: Cells(j, 11) = Y End If Next i = i + 4 CELL_ALL = A + CStr(i) + : + A + CStr(i + 1) Call CELL_FJ(CELL_ALL) CELL_ALL = B + C
