module1.bas

用VB编写的水准平差软件

Attribute VB_Name = "Module1"
Const Pi = 3.1415926
Public Function count(a, str As String) As Integer    ''''求取矩阵的行数和列数
Dim upper, lower As Integer
If (str = "hangshu") Then
upper = UBound(a, 1)
lower = LBound(a, 1)
count = upper - lower
Else
upper = UBound(a, 2)
lower = LBound(a, 2)
count = upper - lower
End If
End Function
Public Function AngleToRadian(angle As Double) As Double                '角度化弧度
Dim d As Integer
Dim f As Integer
Dim m As Double
angle = angle + 0.0000000001
d = Int(Abs(angle)) * Sgn(angle)
f = Int(Abs((angle - d) * 100)) * Sgn((angle - d) * 100)
m = ((angle - d) * 100 - f) * 100
'Print d
'Print f
'Print m
AngleToRadian = (CDbl(m) / 3600 + CDbl(f) / 60 + CDbl(d)) * Pi / 180
'AngleToRadian = Sgn(angle) * AngleToRadian
'Print AngleToRadian
End Function
Public Function RadianToAngle(radian As Double) As Double              '弧度化角度
Dim angle As Double
Dim d As Integer
Dim f As Integer
Dim m As Double
Do While (radian > (2 * Pi))
radian = radian - 2 * Pi
Loop
angle = radian * 180 / Pi
d = Int(Abs(angle)) * Sgn(angle)
f = Int(Abs((angle - d) * 60)) * Sgn((angle - d) * 60)
m = ((angle - d) * 60 - f) * 60
RadianToAngle = CDbl(d) + CDbl(f) / 100 + m / 10000
'RadianToAngle = Sgn(radian) * RadianToAngle
End Function
 Private Function ArcSin(X As Single) As Single                  '''''''''''反正弦函数
          If X = 1 Then
                  ArcSin = Pi / 2
          ElseIf X = -1 Then
                  ArcSin = Pi * 3 / 2
          Else
                  ArcSin = Atn(X / Sqr(-X * X + 1))
          End If
End Function
Function matrix_multi(a, b)     ''矩阵乘法
    m = count(a, "hangshu")
    n = count(b, "lieshu")
    k = count(a, "leishu")
    k1 = count(b, "hangshu")
    If (k <> k1) Then
    MsgBox ("代计算矩阵不满足要求，第一个的列数不等于第二个的行数")
    End
    Else
    ReDim c(m, n)
        For i = 0 To m
            For j = 0 To n
                For l = 0 To k
                    c(i, j) = a(i, l) * b(l, j) + c(i, j)
                Next l
            Next j
        Next i
        matrix_multi = c
    End If
End Function
Function matrix_multi_C(a, b) '矩阵乘法
    m = count(b, "hangshu")
    n = count(b, "lieshu")
    ReDim c(m, n)
        For i = 0 To m
            For j = 0 To n
                c(i, j) = a * b(i, j)
            Next j
        Next i
      matrix_multi_C = c
End Function
Function matrix_inverse(a) '矩阵求逆
    n = count(a, "hangshu")
    m = count(a, "lieshu")
    If (m <> n) Then
    MsgBox ("该矩阵不能求行列式，因为行数和列数不相同！！")
    End
    Else
        ReDim mm(n, (2 * n))
        ReDim b(n, n)
        For i = 0 To n - 1
            For j = 0 To n - 1
                mm(i, j) = a(i, j)
                mm(i, i + n) = 1
            Next j
        Next i
         For i = 0 To n - 1
            If (mm(i, i) = 0) Then
                For j = (i + 1) To n - 1
                    If (mm(j, i) <> 0) Then
                        For k = i To (n * 2) - 1
                            temp = mm(j, k)
                            mm(j, k) = mm(i, k)
                            mm(i, k) = temp
                        Next k
                        GoTo bbb
bbb:                End If
                Next j
            End If
aaa:            If (mm(i, i) = 0) Then
                MsgBox ("asdfsadfsadfsdafafs")
                End If
            For j = (i + 1) To n - 1
                If (mm(j, i) <> 0) Then
                    c = -mm(j, i) / mm(i, i)
                    For k = i To (n * 2) - 1
                        mm(j, k) = mm(j, k) + c * mm(i, k)
                    Next k
                End If
            Next j
        Next i
        For i = n - 1 To 0 Step -1 '计算逆矩阵
            d = mm(i, i)
            For k = i To (n * 2) - 1
                mm(i, k) = mm(i, k) / d
            Next k
            For j = (i - 1) To 0 Step -1
                d = -mm(j, i)
                For k = i To (n * 2) - 1
                    mm(j, k) = mm(j, k) + d * mm(i, k)
                Next k
            Next j
        Next i
        For i = 0 To n - 1
            For k = n To (n * 2) - 1
                b(i, k - n) = mm(i, k)
            Next k
        Next i
        matrix_inverse = b
    End If
End Function
Function matrix_add(a, b) '矩阵加法
    m = count(a, "hangshu")
    n = count(a, "lieshu")
    m1 = count(b, "hangshu")
    n1 = count(b, "lieshu")
    If ((m <> m1) Or (n <> n1)) Then
    MsgBox ("矩阵加法运算中维数不满足要求")
    End
    Else
        ReDim c(m, n)
        For i = 0 To m - 1
            For j = 0 To n - 1
                c(i, j) = a(i, j) + b(i, j)
            Next j
        Next i
    matrix_add = c
End If
End Function
Function matrix_sub(a, b) '矩阵减法
    m = count(a, "hangshu")
    n = count(a, "lieshu")
    m1 = count(b, "hangshu")
    n1 = count(b, "lieshu")
    If ((m <> m1) Or (n <> n1)) Then
    MsgBox ("矩阵减法运算中维数不满足要求")
    End
    Else
        ReDim c(m, n)
        For i = 0 To m - 1
            For j = 0 To n - 1
                c(i, j) = a(i, j) - b(i, j)
            Next j
        Next i
    matrix_sub = c
End If
End Function

Function matrix_trans(a) '矩阵转置
    m = count(a, "hangshu")
    n = count(a, "lieshu")
    ReDim b(n, m)
    For i = 0 To m - 1
        For j = 0 To n - 1
            b(j, i) = a(i, j)
        Next j
    Next i
    matrix_trans = b
End Function
Function matrix_zhi(mm) As Double    '计算方阵的行列式
    m = count(mm, "hangshu")
    n = count(mm, "lieshu")
    If (m <> n) Then
    MsgBox ("该矩阵不能求行列式，因为行数和列数不相同！！")
    End
    Else
            For i = 0 To n - 1
                If (mm(i, i) = 0) Then
                    For j = (i + 1) To n - 1
                        If (mm(j, i) <> 0) Then
                            Counter = 0
                            For k = i To n
                                temp = mm(j, k)
                                mm(j, k) = mm(i, k)
                                mm(i, k) = temp
                                Counter = Counter + 1
                            Next k
                            GoTo bbb
bbb:                    End If
                    Next j
                 End If
                If (mm(i, i) = 0) Then
                MsgBox ("asdfsdaf")
                End If
                For j = (i + 1) To n - 1
                    If (mm(j, i) <> 0) Then
                        c = -mm(j, i) / mm(i, i)
                        For k = i To n - 1
                            mm(j, k) = mm(j, k) + c * mm(i, k)
                        Next k
                    End If
                Next j
            Next i
            q = 1
            For i = 0 To n - 1
                q = mm(i, i) * q
            Next i
                If (Counter Mod 2 = 0) Then
                    d = q
                Else
                    d = -q
                End If
        matrix_zhi = d
       End If
End Function