附合导线平差主窗体.frm

一个附和导线的严密计算平差程序

Private Sub Form_Resize()
    With MSFlexGrid1
        .Left = 0
        .Top = tbrMain.Top + tbrMain.Height
        If Me.ScaleHeight >= tbrMain.Height Then
        .Width = Me.ScaleWidth
        .Height = Me.ScaleHeight - .Top
        End If
    End With
End Sub

Private Sub mnuDataBihe_Click()
    frmBihecha.Show
End Sub

Private Sub mnuDataChuli_Click()             '数据处理
  Dim i As Integer, j As Integer, m As Integer
  Dim Deerta0 As Single           '得尔塔0为单位权中误差
  Dim NN(100, 100) As Single
  Dim E(3, 3) As Double
  Dim VVa As Single, VVb As Single
  Dim CosA0(100) As Single, SinA0(100) As Single       '余玄和正玄值
  Dim Xcha(100) As Single, Ycha(100) As Single  'Xcha，Ycha为终点坐标与前intcount-1个点的坐标差
  
  Deerta0 = mm                       '定单位权
  For i = 1 To IntCount - 1           '求边的权重
    If ma = 0 Then
     Ps(i) = Deerta0 ^ 2 / (mb ^ 2 * InputDat(i).Bianchang)
     Else
     Ps(i) = Deerta0 ^ 2 / (ma + mb * 0.001 * InputDat(i).Bianchang) ^ 2
    End If
  Next i
  
  For i = 1 To IntCount              '求左角的权重
    Pb(i) = 1
  Next i
  
  For i = 1 To IntCount               '求近似方位角
   If i = 1 Then
     a0(i) = DFMDu(aa(1)) + DFMDu(InputDat(i).Guancejiao)
    Else
     a0(i) = a0(i - 1) + 180 + DFMDu(InputDat(i).Guancejiao)
   End If
   Do While a0(i) > 360
    a0(i) = a0(i) - 360
   Loop
  Next i
 
 For i = 1 To IntCount                      '求近似坐标
   If i = 1 Then
     X0(i) = xx(1)
     Y0(i) = yy(i)
     Else
     X0(i) = X0(i - 1) + InputDat(i - 1).Bianchang * Cos(DuHudu(a0(i - 1)))
     Y0(i) = Y0(i - 1) + InputDat(i - 1).Bianchang * Sin(DuHudu(a0(i - 1)))
   End If
 Next i
 
 Wa = DuM((a0(IntCount) - DFMDu(aa(2))))    '求方位角、X和Y闭合差
 Wx = (X0(IntCount) - xx(2)) * 1000
 Wy = (Y0(IntCount) - yy(2)) * 1000
 
 W(1) = Wa
 W(2) = Wx
 W(3) = Wy
 For i = 1 To IntCount - 1
  CosA0(i) = Cos(DuHudu(a0(i)))
  SinA0(i) = Sin(DuHudu(a0(i)))
 Next i
 For i = 1 To IntCount - 1
   Xcha(i) = (X0(IntCount) - X0(i)) / RuoC
   Ycha(i) = -(Y0(IntCount) - Y0(i)) / RuoC
 Next i
 
 For i = 1 To 3                             '求条件方程式系数
  For j = 1 To IntCount * 2 - 1
   If i = 1 Then
     If j <= IntCount Then
       a(i, j) = 1
      Else
      a(i, j) = 0
     End If
   End If
   If i = 2 Then
     If j < IntCount Then
      a(i, j) = Ycha(j)
       Else
        If j > IntCount Then
         a(i, j) = CosA0(j - IntCount)
         Else
          a(i, j) = 0
        End If
     End If
   End If
   If i = 3 Then
     If j < IntCount Then
      a(i, j) = Xcha(j)
      Else
      If j > IntCount Then
       a(i, j) = SinA0(j - IntCount)
       Else
        a(i, j) = 0
      End If
     End If
   End If
  Next j
 Next i
 
For i = 1 To IntCount * 2 - 1                 '求Q矩阵
 For j = 1 To IntCount * 2 - 1
  If (i <= IntCount) And (i = j) Then
     Q(i, j) = 1 / Pb(i)
     Else
      If (i > IntCount) And (i = j) Then
       Q(i, j) = 1 / Ps(i - IntCount)
      Else
       Q(i, j) = 0
      End If
  End If
 Next j
Next i

For i = 1 To 3                                '求N矩阵
 For j = 1 To IntCount * 2 - 1
  NN(i, j) = 0
  For m = 1 To IntCount * 2 - 1
   NN(i, j) = NN(i, j) + a(i, m) * Q(m, j)
  Next m
 Next j
Next i
For i = 1 To 3
 For j = 1 To 3
  n(i, j) = 0
  For m = 1 To IntCount * 2 - 1
   n(i, j) = n(i, j) + NN(i, m) * a(j, m)
   Next m
 Next j
Next i
  
  ReDim nnn(2, 2)                          '求N的逆矩阵
For i = 1 To 3
 For j = 1 To 3
  nnn(i - 1, j - 1) = n(i, j)
 Next j
Next i

Call jz_con(nnn)

For i = 1 To 3                             '求K阵
 K(i) = 0
 For j = 1 To 3
  K(i) = K(i) - nnn(i - 1, j - 1) * W(j)
 Next j
Next i

For i = 1 To IntCount * 2 - 1              '求左角和边长改正数
 For j = 1 To IntCount * 2 - 1
  NN(i, j) = 0
  For m = 1 To IntCount * 2 - 1
   NN(i, j) = NN(i, j) + Q(i, m) * a(j, m)
  Next m
 Next j
Next i
For i = 1 To IntCount * 2 - 1
  v(i) = 0
  For m = 1 To 3
   v(i) = v(i) + NN(i, m) * K(m)
  Next m
Next i

For i = 1 To IntCount - 1              '求边长改正数和改正后的边长
 Vs(i) = v(i + IntCount)
 s(i) = Vs(i) / 1000 + InputDat(i).Bianchang
Next i

VVa = 0
For i = 1 To IntCount                  '求方位角改正数、方位角改正后的角度和X,Y改正后的坐标
 Va(i) = VVa + v(i)
 ZBJG(i).a = a0(i) + Va(i) / 3600
 If i = 1 Then
   ZBJG(i).x = xx(1)
   ZBJG(i).y = yy(1)
  Else
   ZBJG(i).x = ZBJG(i - 1).x + s(i - 1) * Cos(DuHudu(ZBJG(i - 1).a))
   ZBJG(i).y = ZBJG(i - 1).y + s(i - 1) * Sin(DuHudu(ZBJG(i - 1).a))
 End If
 VVa = Va(i)
Next i

m0 = 0
For i = 1 To IntCount * 2 - 1          '求单位权中误差
  If i <= IntCount Then
    m0 = m0 + v(i) * v(i) * Pb(i)
  Else
    m0 = m0 + v(i) * v(i) * Ps(i - IntCount)
  End If
Next i

m0 = Sqr(m0 / 3)

Call QiuQLLzhen(QLL)                   '求观测值权阵
Call QiuDianweiXS(Vaxy)                '求坐标改正数系数
Call QiuDianweiQuan(QFF)               '求QFF阵

Call QiuDianweiJD(ZBJG)                '求纵横坐标中误差和点位中误差
Call QiuDianTuoyuan(ZBJG)              '求点的误差椭圆元素
Call QiuWZDJTY(Wzdty)                  '求未知点间误差椭圆元素

Call QiuBianHeFangweiJiaoJD(Qas)
Call QiuMsMa

mnuOutV.Enabled = True
mnuDataChuli.Enabled = False
mnuDataOutput.Enabled = True
End Sub

Private Sub mnuDataInput_Click()             '数据输入
  Dim Sum As Integer, i As Integer
  Dim msg As String
  If KCount < 2 Then
   msg = MsgBox("数据输入有误", vbCritical + vbOKOnly, "出错提示")
   If msg = vbOK Then
     Exit Sub
   End If
  End If
  mm = Val(frmYizhiShuju.Text1.Text)               '把已知数据导入变量中
  ma = Val(frmYizhiShuju.Text2.Text)
  mb = Val(frmYizhiShuju.Text13.Text)
  kk = 2
  PointHao(1) = Val(frmYizhiShuju.Text3.Text)
  PointName(1) = Trim(frmYizhiShuju.Text4.Text)
  xx(1) = Val(frmYizhiShuju.Text5.Text)
  yy(1) = Val(frmYizhiShuju.Text6.Text)
  aa(1) = Val(frmYizhiShuju.Text7.Text)
  PointHao(2) = Val(frmYizhiShuju.Text8.Text)
  PointName(2) = Trim(frmYizhiShuju.Text9.Text)
  xx(2) = Val(frmYizhiShuju.Text10.Text)
  yy(2) = Val(frmYizhiShuju.Text11.Text)
  aa(2) = Val(frmYizhiShuju.Text12.Text)
  
  Sum = 0               '求表中记录数
  i = 1
 Do While i <= KCount
     If Len(Trim(MSFlexGrid1.TextMatrix(i, 1))) <> 0 Then
       Sum = Sum + 1
     End If
   i = i + 1
  Loop

IntCount = Sum               '把表中的记录导入记录数组中
 For i = 1 To Sum
    With InputDat(i)
     .ICount = Val(Trim(MSFlexGrid1.TextMatrix(i, 1)))
     .PiontName = MSFlexGrid1.TextMatrix(i, 2)
     .Guancejiao = Val(Trim(MSFlexGrid1.TextMatrix(i, 3)))
     .Bianchang = Val(Trim(MSFlexGrid1.TextMatrix(i, 4)))
   End With
 Next i
 mnuDataChuli.Enabled = True
 mnuDataInput.Enabled = False
 mnuDataBihe.Enabled = True
 mnuDataCucha.Enabled = True
End Sub

Private Sub mnuDataORInput_Click()
 frmYizhiShuju.Visible = True
 mnuDataInput.Enabled = True
End Sub

Private Sub mnuEditCopy_Click()
    Clipboard.Clear
    Clipboard.SetText MSFlexGrid1.Clip

End Sub

Private Sub mnuEditcut_Click()
    Clipboard.Clear
    Clipboard.SetText MSFlexGrid1.Clip
    Dim i As Integer
    Dim j As Integer
    Dim strClip As String
    With MSFlexGrid1
        For i = 1 To .RowSel
            For j = 1 To .ColSel
                strClip = strClip & "" & vbTab
            Next
            strClip = strClip & vbCr
        Next
        .Clip = strClip
    End With
    MakeUndoBuffer "Cut"

End Sub

Private Sub mnuEditDelete_Click()
    Dim i As Integer
    Dim j As Integer
    Dim strClip As String
    With MSFlexGrid1
        For i = 1 To .RowSel
            For j = 1 To .ColSel
                strClip = strClip & "" & vbTab
            Next
            strClip = strClip & vbCr
        Next
        .Clip = strClip
    End With
    MakeUndoBuffer "Delete"

End Sub

Private Sub mnuEditDelRow_Click()
    With MSFlexGrid1
        If .Rows > 2 Then
            .RemoveItem .row
            MakeUndoBuffer "Remove Row"
        KCount = KCount - 1
        End If
    End With
    txtEdit.Text = MSFlexGrid1.TextMatrix(m_ActiveCell.row, m_ActiveCell.col)
    txtEdit.Visible = False
End Sub

Private Sub mnuEditInsertRow_Click()
    MSFlexGrid1.AddItem "", MSFlexGrid1.row
    MakeUndoBuffer "Insert Row"
    KCount = KCount + 1
    txtEdit.Text = ""
    txtEdit.Visible = False
End Sub

Private Sub mnuEditPaste_Click()
    If Len(Clipboard.GetText) Then
        MSFlexGrid1.Clip = Clipboard.GetText
        MakeUndoBuffer "Paste"
    End If

End Sub

Private Sub mnuEditSelectAll_Click()
    With MSFlexGrid1
        .Visible = False
        .row = 1
        .col = 1
        .RowSel = .Rows - 1
        .ColSel = .Cols - 1
        .TopRow = 1
        .Visible = True
    End With

End Sub

Private Sub mnuEditUndo_Click()
    Undo
End Sub

Private Sub mnuFileExit_Click()    '当退出时释放内存
  Unload Me
  Unload frmHuaTuoYuan
  Unload frmXianshiJG
  Unload frmYizhiShuju
End Sub

Private Sub mnuFileNew_Click()
  frmYizhiShuju.Visible = True
  frmYizhiShuju.Text1 = ""
  frmYizhiShuju.Text2 = ""
  frmYizhiShuju.Text3 = ""
  frmYizhiShuju.Text4 = ""
  frmYizhiShuju.Text5 = ""
  frmYizhiShuju.Text6 = ""
  frmYizhiShuju.Text7 = ""
  frmYizhiShuju.Text8 = ""
  frmYizhiShuju.Text9 = ""
  frmYizhiShuju.Text10 = ""
  frmYizhiShuju.Text11 = ""
  frmYizhiShuju.Text12 = ""
  frmYizhiShuju.Text13 = ""
  If MSFlexGrid1.Rows > 2 Then
    For i = MSFlexGrid1.Rows - 1 To 2 Step -1
       MSFlexGrid1.RemoveItem (i)
    Next i
  End If
  For i = 1 To MSFlexGrid1.Cols - 1
    MSFlexGrid1.TextMatrix(1, i) = ""
  Next i
  KCount = 1
  mnuDataInput.Enabled = True
End Sub

Private Sub mnuFileOpen_Click()
 Dim Lastposition As Variant
 Dim InputData As String, msg As String
 Dim i As Integer, j As Integer, L As Integer
   On Error GoTo ErrHandler
   CommonDialog1.FileName = "*.TXT"
   CommonDialog1.InitDir = "c:\My documents"
   CommonDialog1.Filter = "文本文件(*.TXT)|*.TXT|文挡(*.DOC)|*.DOC|All Files(*.*)|*.*"
   CommonDialog1.Action = 1
   StrFilename = CommonDialog1.FileName