module1.bas

用于摄影测量航带网概算的程序

  Dim idd As Integer
  For idd = 1 To 3
    For jdd = 1 To 3
     R(idd, jdd) = R(idd, jdd) * jnenm
    Next jdd
  Next idd
  ReDim dao1(1 To 3, 1 To 1)
  For i = 1 To num(1)
     '模型点坐标转化为参考坐标
     dao1(1, 1) = Xmo(1, i): dao1(2, 1) = Ymo(1, i): dao1(3, 1) = Zmo(1, i)
     myflag = multi(R(), dao1(), dao2())
     dao3(1, 1) = dao2(1, 1) + jXs
     dao3(2, 1) = dao2(2, 1) + jYs
     dao3(3, 1) = dao2(3, 1) + jZs
     
     '参考坐标转化为大地坐标
     myflag = multi(juzhen(), dao3(), dao4())
     dadi1(i, 1) = dao4(1, 1) / (nenm * nenm) + mmm
     dadi1(i, 2) = dao4(2, 1) / (nenm * nenm) + nnn
     dadi1(i, 3) = dao4(3, 1) / (nenm * nenm)
  Next i
  For i = 1 To num(2)
     '模型点坐标转化为参考坐标
     dao1(1, 1) = Xmo(2, i): dao1(2, 1) = Ymo(2, i): dao1(3, 1) = Zmo(2, i)
     myflag = multi(R(), dao1(), dao2())
     dao3(1, 1) = dao2(1, 1) + jXs
     dao3(2, 1) = dao2(2, 1) + jYs
     dao3(3, 1) = dao2(3, 1) + jZs
     
     '参考坐标转化为大地坐标
     myflag = multi(juzhen(), dao3(), dao4())
     dadi2(i, 1) = dao4(1, 1) / (nenm * nenm) + mmm
     dadi2(i, 2) = dao4(2, 1) / (nenm * nenm) + nnn
     dadi2(i, 3) = dao4(3, 1) / (nenm * nenm)
  Next i
End Sub


Rem 把文本框内的内容写入文件
Function SaveTextControl(TB As Control, CD As CommonDialog, filename As String) As Boolean
    Dim filenum As Integer
    On Error GoTo ExitNow
    
    CD.Filter = "All files (*.*)|*.*|Text files|*.txt"
    CD.FilterIndex = 2
    CD.DefaultExt = "txt"
    If TypeName(TB) = "RichTextBox" Then
        CD.Filter = CD.Filter & "|RTF files|*.rtf"
        CD.FilterIndex = 3
        CD.DefaultExt = "rtf"
    End If
    CD.Flags = cdlOFNHideReadOnly Or cdlOFNPathMustExist Or _
        cdlOFNOverwritePrompt Or cdlOFNNoReadOnlyReturn
    CD.DialogTitle = "Select the destination file "
    CD.filename = filename
    ' Exit if user presses Cancel.
    CD.CancelError = True
    CD.ShowSave
    filename = CD.filename
    
    ' Write the control's contents.
    filenum = FreeFile()
    Open filename For Output As #filenum
    If TypeName(TB) = "RichTextBox" Then
        Print #filenum, TB.TextRTF;
    Else
        Print #filenum, TB.Text;
    End If
    Close #filenum
    ' Signal success.
    SaveTextControl = True
ExitNow:
End Function

Rem 把文件的内容读入文本框

 Function LoadTextControl(TB As Control, CD As CommonDialog, filename As String) As Boolean
    Dim filenum As Integer
    On Error GoTo ExitNow
    
    CD.Filter = "All files (*.*)|*.*|Text files|*.txt"
    CD.FilterIndex = 2
    CD.DefaultExt = "txt"
    If TypeName(TB) = "RichTextBox" Then
        CD.Filter = CD.Filter & "|RTF files|*.rtf"
        CD.FilterIndex = 3
        CD.DefaultExt = "rtf"
    End If
    CD.Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or _
        cdlOFNNoReadOnlyReturn
    CD.DialogTitle = "Select the source file "
    CD.filename = filename
    ' Exit if user presses Cancel.
    CD.CancelError = True
    CD.ShowOpen
    filename = CD.filename
    
    ' Read the file's contents into the control.
    filenum = FreeFile()
    Open filename For Input As #filenum
    If TypeName(TB) = "RichTextBox" Then
        TB.TextRTF = Input$(LOF(filenum), filenum)
    Else
       ' TB.Text = Input$(LOF(filenum), filenum)
       Dim inbuf As String
       Do While Not EOF(filenum)
          Line Input #filenum, inbuf
          TB.Text = TB.Text & inbuf & vbCrLf
       Loop
    End If
    Close #filenum
    ' Signal success.
    LoadTextControl = True
ExitNow:

End Function

'数组转置
Public Function zhuanzhi(fir() As Double, las() As Double) As Boolean
   On errror GoTo err_hander
   Dim i As Integer, j As Integer
   ReDim las(LBound(fir(), 2) To UBound(fir(), 2), LBound(fir()) To UBound(fir()))
   For i = LBound(fir()) To UBound(fir())
       For j = LBound(fir(), 2) To UBound(fir(), 2)
           las(j, i) = fir(i, j)
       Next j
   Next i
   zhuanzhi = True
   Exit Function
err_hander: MsgBox "数组转置未成功"
            zhuanzhi = False
End Function

'矩阵相乘
Public Function multi(fir() As Double, sec() As Double, las() As Double) As Boolean
     On Error GoTo err_hander
     Dim i As Integer, j As Integer
     Dim dims1 As Integer, dims2 As Integer
     dims1 = NumberOfDims(fir())
     dims2 = NumberOfDims(sec())
     '两矩阵都是一维的
     If dims1 = 1 And dims2 = 1 Then
        ReDim las(1 To 1, 1 To 1)
        las(1, 1) = fir(LBound(fir)) * sec(LBound(sec))
     End If
     '第一个矩阵是一维的
     If dims1 = 1 And dims2 <> 1 Then
        ReDim las(1 To 1, 1 To 1)
        For i = LBound(fir()) To UBound(fir)
            las(1, 1) = las(1, 1) + fir(i) * sec(i, 1)
        Next i
     End If
     '第二个矩阵是一维的
     If dims1 <> 1 And dims2 = 1 Then
        ReDim las(1 To UBound(fir) - LBound(fir) + 1)
        For i = 1 To UBound(las)
             For j = 1 To UBound(fir, 2)
                las(i) = las(i) + fir(i, j) * sec(j)
             Next j
        Next i
     End If
     '两个矩阵都不是一维的
     If dims1 <> 1 And dims2 <> 1 Then
     Dim m As Integer, N As Integer
     ReDim las(1 To UBound(fir()) - LBound(fir()) + 1, 1 To UBound(sec(), 2) - LBound(sec(), 2) + 1)
     i = LBound(fir())
     For m = 1 To UBound(las())
         i = i + 1
         For N = 1 To UBound(las(), 2)
            For j = LBound(fir(), 2) To UBound(fir(), 2)
                las(m, N) = las(m, N) + fir(i - 1, j) * sec(j, N + LBound(sec(), 2) - 1)
            Next j
         Next N
     Next m
     End If
     multi = True
     Exit Function
err_hander: MsgBox "数组维数不符合要求"
            multi = False
End Function

'消去法求解方程
Public Function xiaoqu(c() As Double, w() As Double, result() As Double) As Boolean
       On Error GoTo err_hander
       Dim i As Integer, j As Integer, lcount As Integer
       Dim tans As Double
       ReDim result(LBound(w()) To UBound(w()))
       
       For lcount = LBound(c()) To UBound(c()) - 1
       
           '列主元
           j = lcount
           For i = lcount To UBound(c())
               If Abs(c(i, 1)) > Abs(c(j, 1)) Then
                  j = i
               End If
           Next i
           If j <> lcount Then
             For i = lcount To UBound(c(), 2)
                 tans = c(lcount, i)
                 c(lcount, i) = c(j, i)
                 c(j, i) = tans
             Next i
           End If
           '化算矩阵
           For i = lcount + 1 To UBound(c())
               tans = c(i, lcount)
               For j = lcount To UBound(c(), 2)
                     c(i, j) = c(i, j) - c(lcount, j) * tans / c(lcount, lcount)
               Next j
               w(i) = w(i) - w(lcount) * tans / c(lcount, lcount)
           Next i
       Next lcount
           
           '回代
       tans = 0
       result(UBound(result())) = w(UBound(w())) / c(UBound(c()), UBound(c(), 2))
       For i = UBound(result()) - 1 To LBound(c()) Step -1
           For j = i + 1 To UBound(c())
                tans = tans + c(i, j) * result(j)
           Next j
           result(i) = (w(i) - tans) / c(i, i)
       Next i
       xiaoqu = True
       Exit Function
err_hander:   MsgBox "数组非方阵,或其数值有错"
              xiaoqu = False
End Function
'求逆阵
Public Function invers(fir() As Double, las() As Double) As Boolean
     On Error GoTo err_hander
     '为求逆作准备
     Dim i As Integer, j As Integer, m As Integer
     Dim N As Integer, c As Double               'N用于存放矩阵维数
     N = UBound(fir()) - LBound(fir()) + 1
     ReDim Preserve fir(1 To N, 1 To 2 * N)      '附加上一单位矩阵
     For i = 1 To N
         fir(i, N + i) = 1
     Next i
     
     '求逆
     
     '先顺序向下运算，求得一上三角阵
     c = fir(1, 1)
     For j = 1 To 2 * N                          '化算第一行
         fir(1, j) = fir(1, j) / c
     Next j
     
     For i = 1 To N - 1                          '化算余下的行
         For m = i + 1 To N
             c = fir(m, i)
             For j = i To 2 * N
                 fir(m, j) = fir(m, j) - fir(i, j) * c
             Next j
         Next m
         c = fir(i + 1, i + 1)
         For j = 1 To 2 * N                  '把对角线上的元素化为1
             fir(i + 1, j) = fir(i + 1, j) / c
         Next j
     Next i
     
     '在逆序向上，最后求的一单位阵
     For i = N To 2 Step -1
         For m = i - 1 To 1 Step -1
             c = fir(m, i)
             For j = m + 1 To 2 * N
                 fir(m, j) = fir(m, j) - fir(i, j) * c
             Next j
         Next m
     Next i
     
     '现在得到的矩阵，其右半部分就是所要求的逆阵
     '把右半部分赋给结果矩阵
     ReDim las(1 To N, 1 To N)
     For i = 1 To N
         For j = 1 To N
             las(i, j) = fir(i, N + j)
         Next j
     Next i
     invers = True
     Exit Function
err_hander: MsgBox "矩阵不是方阵" & Chr(10) & Chr(13) & "或矩阵不是满秩矩阵"
            invers = False
End Function

'数组间赋值
Public Function equalate(arrA() As Double, arrB() As Double) As Boolean
      On Error GoTo err_hander
      Dim i As Integer, j As Integer
      Dim diman As Integer
      diman = NumberOfDims(arrB)
      '把B数组赋给A数组
      'B数组是一维的
      If diman = 1 Then
         ReDim arrA(LBound(arrB) To UBound(arrB))
         For i = LBound(arrB) To UBound(arrB)
              arrA(i) = arrB(i)
         Next i
      End If
      'B数组是二维的
      If diman = 2 Then
        ReDim arrA(LBound(arrB) To UBound(arrB), LBound(arrB, 2) To UBound(arrB, 2))
        For i = LBound(arrB) To UBound(arrB)
            For j = LBound(arrB, 2) To UBound(arrB, 2)
                arrA(i, j) = arrB(i, j)
            Next j
        Next i
      End If
      equalate = True
      '错误处理
      Exit Function
err_hander: MsgBox "数组为空"
            equalate = False
End Function
'消去法求解方程
Public Function solveFa1(a() As Double, L() As Double, P() As Double, x() As Double) As Boolean
       On Error GoTo err_hander
       Dim c() As Double
       Dim w() As Double
       Dim issuccess As Boolean
       Dim AT() As Double, c1() As Double, w1() As Double
       Dim trans() As Double
       '求A()的转置矩阵At()
       issuccess = zhuanzhi(a(), AT())
       If issuccess = False Then MsgBox "数组转置失败": Exit Function
       '求C()
       issuccess = multi(AT(), P(), trans())
       If issuccess = False Then MsgBox "数组相乘失败": Exit Function
       issuccess = multi(trans(), a(), c())
       If issuccess = False Then MsgBox "数组相乘失败": Exit Function
       '求w()
       issuccess = multi(AT(), P(), trans())
       If issuccess = False Then MsgBox "数组相乘失败": Exit Function
       issuccess = multi(trans(), L(), w())
       If issuccess = False Then MsgBox "数组相乘失败": Exit Function
       '求x()
       issuccess = invers(c(), trans())
       issuccess = multi(trans(), w(), x())
       solveFa1 = True
       '错误处理
       Exit Function
err_hander: MsgBox "所给元素有错，解方程为成功"
            solveFa1 = False
End Function
'求数组维数
Public Function NumberOfDims(arr() As Double) As Integer
       Dim dummy As Long
       On Error Resume Next
       Do
          dummy = UBound(arr, NumberOfDims + 1)
          If Err Then Exit Do
          NumberOfDims = NumberOfDims + 1
       Loop
End Function

Rem 自定义函数，用于按指定字符分离字符串

Public Function mysplit(ByVal myobj As String, myfl As String, myaim() As String) As Boolean
       On Error GoTo err_hander
       '去掉前导无用字符
       Do While Asc(myobj) = 32 Or Asc(myobj) = 13 Or Asc(myobj) = 10
          myobj = Mid$(myobj, 2)
       Loop
       '去掉后续无用字符
       Do While Asc(Right$(myobj, 1)) = 32 Or Asc(Right$(myobj, 1)) = 13 Or _
                Asc(Right$(myobj, 1)) = 10
          myobj = Left$(myobj, Len(myobj) - 1)
       Loop
       '判断为非空
       If Len(myobj) = 0 Then
             MsgBox "字符串为空"
             Exit Function
       End If
       '循环取个被分割项
       Dim flag As Double, N As Integer
       flag = InStr(myobj, myfl)
       Do While flag > 0
          N = N + 1
          ReDim Preserve myaim(1 To N)
          myaim(N) = Mid$(myobj, 1, flag - 1)
          myobj = Mid$(myobj, flag + 1)
          '每次都去掉前导无用字符
          Do While Asc(myobj) = 32 Or Asc(myobj) = 13 Or Asc(myobj) = 10
              myobj = Mid$(myobj, 2)
          Loop
          flag = InStr(myobj, myfl)
       Loop
       N = N + 1
       ReDim Preserve myaim(1 To N)
       myaim(N) = Mid$(myobj, 1)
       mysplit = True
err_hander: If Err Then
               MsgBox "分离字符串未成功"
               mysplit = False
               Exit Function
            End If
End Function
' 在数组中查找一指定项
Public Function isinit(resource() As Integer, object As Integer) As Integer
   isinit = -1
   Dim count As Integer
   For count = LBound(resouce()) To UBound(resouce())
       If resouce(count) = object Then
          isinit = count
          Exit Function
       End If
   Next i
End Function


Public Function xunzhuan(ByVal fy As Double, ByVal om As Double, ByVal kp As Double, R() As Double) As Boolean
On Error GoTo err_hander
   Dim a1, a2, a3, b1, b2, b3, c1, c2, c3 As Double
   ReDim R(1 To 3, 1 To 3)
   a1 = Cos(fy) * Cos(kp) - Sin(fy) * Sin(om) * Sin(kp)
   a2 = -Cos(fy) * Sin(kp) - Sin(fy) * Sin(om) * Cos(kp)
   a3 = -Sin(fy) * Cos(om)
   b1 = Cos(om) * Sin(kp)
   b2 = Cos(om) * Cos(kp)
   b3 = -Sin(om)
   c1 = Sin(fy) * Cos(kp) + Cos(fy) * Sin(om) * Sin(kp)
   c2 = -Sin(fy) * Sin(kp) + Cos(fy) * Sin(om) * Cos(kp)
   c3 = Cos(fy) * Cos(om)
   R(1, 1) = a1: R(1, 2) = a2: R(1, 3) = a3
   R(2, 1) = b1: R(2, 2) = b2: R(2, 3) = b3
   R(3, 1) = c1: R(3, 2) = c2: R(3, 3) = c3
   Exit Function
err_hander:
   MsgBox "求旋转矩阵出错"
End Function