mdladjust.bas

测量间接平差vb源代码,测量工作者的福音

Attribute VB_Name = "mdlAdjust"
Const PI = 3.14159265358979
Const RU = 206264.8


'求反余弦的函数：输入的是余弦值，输出的是第一象限的弧度值
Public Function ArcCos(ByVal x#) As Double
    If x = 0 Then
        x = PI / 2
    ElseIf x = -1 Then
        x = PI
    ElseIf x > 0 Then
        x = Atn(Sqr((1 / x) ^ 2 - 1))
    Else
        x = PI - Atn(Sqr((1 / x) ^ 2 - 1))
    End If
    
    ArcCos = x
End Function

'求AB的坐标方位角，输入是两点坐标，输出的是弧度值
Public Function DirectAB(xA#, yA#, xB#, yB#) As Double
    Dim detX#, detY#, tana#
    detX = xB - xA
    detY = yB - yA
    If Abs(detX) < 0.000001 Then
        If detY > 0 Then
            DirectAB = PI / 2
        Else
            DirectAB = PI * 3 / 2
        End If
    Else
        tana = detY / detX
        DirectAB = Atn(tana)
        If detX < 0 Then
            DirectAB = PI + DirectAB
        ElseIf detX > 0 And detY < 0 Then
            DirectAB = PI * 2 + DirectAB
        End If
    End If
End Function

'弧度化为度.分秒的形式：输入弧度值，输出度.分秒（各占两位）
Public Function HuToDo(ByVal Hu As Double) As Single
    Dim du%, fen%, miao%
    
    Hu = Hu * 180 / PI
    
    du = Fix(Hu)
    Hu = (Hu - du) * 60
    fen = Fix(Hu)
    Hu = (Hu - fen) * 60
    miao = Fix(Hu + 0.5)
    If miao = 60 Then
        fen = fen + 1
        miao = 0
    End If
    If fen = 60 Then
        du = du + 1
        fen = 0
    End If
    HuToDo = du + fen / 100 + miao / 10000
End Function

'将度.分秒形式化为弧度：输入为度.分秒形式，输出为弧度
Public Function DoToHu(ByVal DoFenMiao As Double) As Single
    Dim du%, fen%, miao%, angle#
    
    du = Fix(DoFenMiao)
    DoFenMiao = (DoFenMiao - du) * 100
    fen = Fix(DoFenMiao)
    miao = (DoFenMiao - fen) * 100
    
    angle = du + fen / 60 + miao / 3600
    DoToHu = angle * PI / 180
End Function

'求AB两点间的距离
Public Function DistAB(xA#, yA#, xB#, yB#) As Double
    Dim detX#, detY#
    detX = xB - xA:    detY = yB - yA
    DistAB = Sqr(detX * detX + detY * detY)
End Function


'由三角形顶点求内角的子过程
Public Sub GetInnerAngle(xA#, yA#, xB#, yB#, Xc#, Yc#, a#, b#, c#)
    Dim Sa#, Sb#, Sc#, cosa#, cosb#, cosc#
    
    Sa = Sqr((Xc - xB) * (Xc - xB) + (Yc - yB) * (Yc - yB))
    Sb = Sqr((Xc - xA) * (Xc - xA) + (Yc - yA) * (Yc - yA))
    Sc = Sqr((xA - xB) * (xA - xB) + (yA - yB) * (yA - yB))
    cosa = (Sb * Sb + Sc * Sc - Sa * Sa) / (2 * Sb * Sc)
    cosb = (Sa * Sa + Sc * Sc - Sb * Sb) / (2 * Sa * Sc)
    cosc = (Sb * Sb + Sa * Sa - Sc * Sc) / (2 * Sa * Sb)
    
    a = ArcCos(cosa): b = ArcCos(cosb): c = ArcCos(cosc)
End Sub

'由三角形边长求内角的子过程
Public Sub GetInnerAngleS(Sa#, Sb#, Sc#, a#, b#, c#)
    Dim cosa#, cosb#, cosc#
    
    cosa = (Sb * Sb + Sc * Sc - Sa * Sa) / (2 * Sb * Sc)
    cosb = (Sa * Sa + Sc * Sc - Sb * Sb) / (2 * Sa * Sc)
    cosc = (Sb * Sb + Sa * Sa - Sc * Sc) / (2 * Sa * Sb)
    
    a = ArcCos(cosa): b = ArcCos(cosb): c = ArcCos(cosc)
End Sub

'计算前方交会点：由A、B两点坐标和角度a、b计算待测点P的坐标
Public Sub ForIntersec(xA#, yA#, xB#, yB#, a#, b#, Xp#, Yp#)
    Dim ctga#, ctgb#
    ctga = 1 / Tan(a):    ctgb = 1 / Tan(b)
    Xp = (xA * ctgb + xB * ctga + (yB - yA)) / (ctga + ctgb)
    Yp = (yA * ctgb + yB * ctga + (xA - xB)) / (ctga + ctgb)
End Sub

'极坐标方法求待定点坐标：依次输入已知两点坐标、边长、夹角、方位角；输出待求坐标
Public Sub PolarPositioning(x1#, y1#, x2#, y2#, dblS#, dblA#, xQ#, yQ#)
    Dim dblD#           '临时的方位角
    dblD = DirectAB(x1, y1, x2, y2)
    dblD = dblD + dblA - PI
    If dblD > (2 * PI) Then dblD = dblD - 2 * PI
    If dblD < 0 Then dblD = dblD + 2 * PI
    xQ = x2 + dblS * Cos(dblD)
    yQ = y2 + dblS * Sin(dblD)
End Sub

'矩阵转置的通用过程
Public Sub MatrixTrans(a, c)
    Dim i%, j%
    Dim R1%, C1%
    On Error Resume Next
    C1 = UBound(a, 2) - LBound(a, 2) + 1
    If Err Then
        MsgBox "输入的矩阵维数不对！"
        Exit Sub
    End If
    R1 = UBound(a, 1) - LBound(a, 1) + 1
    ReDim c(1 To C1, 1 To R1)
    For i = 1 To R1
        For j = 1 To C1
            c(j, i) = a(i, j)
        Next j
    Next i
End Sub

'矩阵相加的通用过程
Public Sub MatrixPlus(a, b, c)
    Dim i%, j%
    Dim R1%, C1%, R2%, C2%
    On Error Resume Next
    C1 = UBound(a, 2) - LBound(a, 2) + 1
    If Err Then
        MsgBox "第一个矩阵维数不对！"
        Exit Sub
    End If
    On Error Resume Next
    C2 = UBound(b, 2) - LBound(b, 2) + 1
    If Err Then
        MsgBox "第二个矩阵维数不对！"
        Exit Sub
    End If
    R1 = UBound(a, 1) - LBound(a, 1) + 1
    R2 = UBound(b, 1) - LBound(b, 1) + 1

    If R1 <> R2 Or C1 <> C2 Then
        MsgBox "输入的两个矩阵维数不等，不能相加！"
        Exit Sub
    End If

    ReDim c(1 To m, 1 To n) As Double
    For i = 1 To m
        For j = 1 To n
            c(i, j) = a(i, j) + b(i, j)
        Next j
    Next i
End Sub

'矩阵相减的通用过程
Public Sub MatrixMinus(a, b, c)
    Dim i%, j%
    Dim R1%, C1%, R2%, C2%
    On Error Resume Next
    C1 = UBound(a, 2) - LBound(a, 2) + 1
    If Err Then
        MsgBox "第一个矩阵维数不对！"
        Exit Sub
    End If
    On Error Resume Next
    C2 = UBound(b, 2) - LBound(b, 2) + 1
    If Err Then
        MsgBox "第二个矩阵维数不对！"
        Exit Sub
    End If
    R1 = UBound(a, 1) - LBound(a, 1) + 1
    R2 = UBound(b, 1) - LBound(b, 1) + 1

    If R1 <> R2 Or C1 <> C2 Then
        MsgBox "输入的两个矩阵维数不等，不能相减！"
        Exit Sub
    End If

    ReDim c(1 To m, 1 To n) As Double
    For i = 1 To m
        For j = 1 To n
            c(i, j) = a(i, j) - b(i, j)
        Next j
    Next i
End Sub

'矩阵相乘：输入矩阵或数Qa、Qb，自动识别它们的维数，并输出它们的乘积Qn
Public Sub Matrix_Multy(Qn, Qa, Qb)
    Dim ia%, ib%, ic%
    Dim ai%, bi%, ci%
    Dim e1 As Boolean, e2 As Boolean, e3 As Boolean, e4 As Boolean, e5 As Boolean, e6 As Boolean, e7 As Boolean
    
    On Error Resume Next '看Qa是不是一维数组
        ic = UBound(Qa, 2) - LBound(Qa, 2)
    If Err Then e1 = True
    On Error Resume Next '看Qa是不是一维数组
        ib = UBound(Qb, 2) - LBound(Qb, 2)
    If Err Then e2 = True
    
    If e1 = False And e2 = False Then '二维矩阵相乘
        For ai = LBound(Qa, 1) To UBound(Qa, 1)
            For bi = LBound(Qb, 2) To UBound(Qb, 2)
                For ci = LBound(Qa, 2) To UBound(Qa, 2)
                    Qn(ai, bi) = Qn(ai, bi) + Qa(ai, ci) * Qb(ci, bi)
                Next ci
            Next bi
        Next ai
    ElseIf e1 = True And e2 = False Then
        On Error Resume Next
            ia = UBound(Qa) - LBound(Qa)
        If Err Then e6 = True
        
        If e6 Then '数乘以二维矩阵
            For ai = LBound(Qb, 1) To UBound(Qb, 1)
                For bi = LBound(Qb, 2) To UBound(Qb, 2)
                    Qn(ai, bi) = Qa * Qb(ai, bi)
                Next bi
            Next ai
        Else '一维矩阵乘以二维矩阵
            For ci = LBound(Qb, 2) To UBound(Qb, 2)
                For ai = LBound(Qa, 1) To UBound(Qa, 1)
                    Qn(ci) = Qn(ci) + Qa(ai) * Qb(ai, ci)
                Next ai
            Next ci
        End If
    ElseIf e1 = False And e2 = True Then
        On Error Resume Next
            ic = UBound(Qb) - LBound(Qb)
        If Err Then e7 = True
        
        If e7 Then '二维矩阵乘以数
            For ai = LBound(Qa, 1) To UBound(Qa, 1)
                For bi = LBound(Qa, 2) To UBound(Qa, 2)
                    Qn(ai, bi) = Qa(ai, bi) * Qb
                Next bi
            Next ai
        Else '二维矩阵乘以一维矩阵
            For ai = LBound(Qa, 1) To UBound(Qa, 1)
                For bi = LBound(Qa, 2) To UBound(Qa, 2)
                    Qn(ai) = Qn(ai) + Qa(ai, bi) * Qb(bi)
                Next bi
            Next ai
        End If
    Else
        Dim errT As Integer
        On Error Resume Next '结果是否是一个数
            errT = UBound(Qn)
        If Err Then e3 = True
        If e3 Then '一维矩阵乘以一维矩阵得一个数
            For ai = LBound(Qa, 1) To UBound(Qa, 1)
                For bi = LBound(Qa, 2) To UBound(Qa, 2)
                    Qn = Qn + Qa(ai) * Qb(bi)
                Next bi
            Next ai
            Exit Sub
        End If
        
        On Error Resume Next '是否是数乘一维矩阵
            ia = UBound(Qa) - LBound(Qa)
        If Err Then e4 = True
        If e4 Then
            For bi = LBound(Qa, 2) To UBound(Qa, 2)
                Qn(bi) = Qa * Qb(bi)
            Next bi
            Exit Sub
        End If
        On Error Resume Next '是否是一维矩阵乘数
            ib = UBound(Qb) - LBound(Qb)
        If Err Then e5 = True
        If e5 Then
            For ai = LBound(Qa, 1) To UBound(Qa, 1)
                Qn(ai) = Qa(ai) * Qb
            Next ai
            Exit Sub
        End If
        
        '一维矩阵相乘结果是二维矩阵
            For ai = LBound(Qa, 1) To UBound(Qa, 1)
                For bi = LBound(Qa, 2) To UBound(Qa, 2)
                    Qn(ai, bi) = Qa(ai) * Qb(bi)
                Next bi
            Next ai
    End If
End Sub

'矩阵相乘的通用过程
Public Sub MatrixMulti(a, b, c)
    Dim i%, j%, k%
    Dim R1%, C1%, R2%, C2%
    On Error Resume Next
    C1 = UBound(a, 2) - LBound(a, 2) + 1
    If Err Then
        MsgBox "第一个矩阵维数不对！"