frmmain.frm

实现对导线测量数据的自动计算和导线图形的显示

'计算改正后的转折角
For i = 1 To PointNum - 1
    RectifyAngle(i) = DMSToDegree(Angle(i)) + (-ErrorAngle / PointNum)
Next
RectifyAngle(PointNum) = DMSToDegree(Angle(PointNum)) - ErrorAngle + (ErrorAngle / PointNum) * (PointNum - 1)

'检验角度闭合差是否为0
Dim temp As Double
For i = 1 To PointNum
    temp = temp + RectifyAngle(i)
    RectifyAngle(i) = DegreeToDMS(RectifyAngle(i))   '度(十进制)转化为度，分，秒
Next
'temp = (PointNum - 2) * 180 - DegreeToDMS(temp)


'二、坐标方位角推算
Azimuth(1) = DMSToDegree(StartAzimuth)
'Azimuth(PointNum + 1) = DMSToDegree(EndAzimuth)
For i = 1 To PointNum
    If AngleDirection = True Then '转折角为右角
        Azimuth(i + 1) = Azimuth(i) + 180 - DMSToDegree(RectifyAngle(i))
    Else
        Azimuth(i + 1) = Azimuth(i) + DMSToDegree(RectifyAngle(i)) - 180
    End If
    If Azimuth(i + 1) > 360 Then Azimuth(i + 1) = Azimuth(i + 1) - 360
    If Azimuth(i + 1) < 0 Then Azimuth(i + 1) = Azimuth(i + 1) + 360
Next


'''坐标方位角计算检核
''If Abs(Azimuth(1) - Azimuth(PointNum + 1)) > 0.000001 Then
''    MsgBox "坐标方位角计算检核失败。", vbCritical, "错误"
''    Exit Sub
''End If

'换成度分秒形式
For i = 1 To PointNum + 1
    Azimuth(i) = DegreeToDMS(Azimuth(i))
Next

'三、坐标增量计算与增量闭合差调整
Dim DeltaXSum As Double, DeltaYSum As Double
Dim DistanceSum As Double
Dim tempRectDistX As Double, tempRectDistY As Double

DeltaXSum = 0: DeltaYSum = 0
DistanceSum = 0: ErrorDist = 0

For i = 1 To PointNum - 1
    '度，分，秒转化为弧度后进行计算
    DeltaX(i) = Distance(i) * Cos(DMSToRadian(Azimuth(i + 1)))
    DeltaY(i) = Distance(i) * Sin(DMSToRadian(Azimuth(i + 1)))
    DeltaXSum = DeltaXSum + DeltaX(i)
    DeltaYSum = DeltaYSum + DeltaY(i)
    DistanceSum = DistanceSum + Distance(i)
Next

DeltaXSum = DeltaXSum - (EndX - StartX)
DeltaYSum = DeltaYSum - (EndY - StartY)

'计算导线全长相对闭合差
ErrorDist = Sqr(DeltaXSum ^ 2 + DeltaYSum ^ 2)
ErrorT = ErrorDist / DistanceSum
ErrorT = 1 / ErrorT
If ErrorT < 2000 Then
    MsgBox "导线全长相对闭合差为1/" & Int(ErrorT) & ",不合格！", vbCritical, "错误"
    Exit Sub
End If


'调整导线全长相对闭合差
For i = 1 To PointNum - 1
    tempRectDistX = (-DeltaXSum) * Distance(i) / DistanceSum
    RectifyDeltaX(i) = DeltaX(i) + tempRectDistX
    tempRectDistY = (-DeltaYSum) * Distance(i) / DistanceSum
    RectifyDeltaY(i) = DeltaY(i) + tempRectDistY
Next


'四、导线点坐标推算
CoordinatePositive Distance(1), DMSToDegree(Azimuth(1)), False, _
                   StartX, StartY, CoX(1), CoY(1)
CoX(2) = StartX: CoY(2) = StartY

For i = 1 To PointNum - 1
    CoX(i + 2) = CoX(i + 1) + RectifyDeltaX(i)
    CoY(i + 2) = CoY(i + 1) + RectifyDeltaY(i)
Next

CoordinatePositive Distance(1), DMSToDegree(Azimuth(PointNum + 1)), True, _
                    EndX, EndY, CoX(PointNum + 2), CoY(PointNum + 2)



'''坐标计算检核
''If Abs(CoX(1) - CoX(PointNum + 1)) > 0.0001 Then
''    MsgBox "X坐标计算检核失败。", vbCritical, "错误"
''    Exit Sub
''End If
''
''If Abs(CoY(1) - CoY(PointNum + 1)) > 0.0001 Then
''    MsgBox "Y坐标计算检核失败。", vbCritical, "错误"
''    Exit Sub
''End If

For i = 1 To PointNum - 1
    DeltaX(i) = Format(DeltaX(i), "#.###")
    DeltaY(i) = Format(DeltaY(i), "#.###")
    RectifyDeltaX(i) = Format(RectifyDeltaX(i), "#.###")
    RectifyDeltaY(i) = Format(RectifyDeltaY(i), "#.###")
    
Next

For i = 1 To PointNum + 2
    CoX(i) = Format(CoX(i), "#.###")
    CoY(i) = Format(CoY(i), "#.###")
Next

End Sub

'*************************
'闭合导线测量函数
'*************************
'
'1、原始数据输入（必选项）
'Angle()输入的原始转折角--注意：是以度分秒形式输入（12.5632表示12度56分32秒）
'Distance()输入的原始边长
'StartAzimuth输入的起算坐标方位角,以度分秒形式输入
'StartX为起算点X坐标
'StartY为起算点Y坐标
'AngleDirection为转折角方向

'2、导线坐标输出（必选项）
'CoX()导线点X坐标
'CoY()导线点Y坐标

'3、中间过程输出
'ErrorSec为角度闭合差
'RectifyAngle()改正后转折角-用度分秒形式
'Azimuth()各边的坐标方位角
'DeltaX()X的增量
'DeltaY()Y的增量
'RectifyDeltaX()改正后X的增量
'RectifyDeltaY()改正后Y的增量
'T导线全长相对闭合差

Sub ClosedTraverse(Angle() As Double, Distance() As Double, ByVal StartAzimuth As Double, _
                    ByVal StartX As Double, ByVal StartY As Double, ByVal AngleDirection As Boolean, _
                    ByRef ErrorSec As Double, RectifyAngle() As Double, Azimuth() As Double, _
                    DeltaX() As Double, DeltaY() As Double, ByRef ErrorDist As Double, _
                    RectifyDeltaX() As Double, RectifyDeltaY() As Double, _
                    CoX() As Double, CoY() As Double, _
                    Optional ByRef ErrorT As Double)


'获取测站点个数
Dim PointNum As Integer
Dim PointDistance As Integer
Dim i As Integer
PointNum = UBound(Angle, 1) - LBound(Angle, 1) + 1
PointDistance = UBound(Distance, 1) - LBound(Distance, 1) + 1

If PointNum <> PointDistance Then
    MsgBox "输入转折角的个数与边长的个数不相等。", vbInformation, "提示"
    Exit Sub
End If


'一、角度闭合差的调整

Dim AngleSum As Double
Dim tempAngle As Double
ReDim RectifyAngle(1 To PointNum)
ReDim Azimuth(1 To PointNum + 1)
ReDim DeltaX(1 To PointNum)
ReDim DeltaY(1 To PointNum)
ReDim RectifyDeltaX(1 To PointNum)
ReDim RectifyDeltaY(1 To PointNum)
ReDim CoX(1 To PointNum + 1)
ReDim CoY(1 To PointNum + 1)

AngleSum = 0
'计算测量转折角的总和
For i = 1 To PointNum
    '把度分秒化为度(十进制)
    tempAngle = DMSToDegree(Angle(i))
    AngleSum = AngleSum + tempAngle
Next

'角度闭合差，用度(十进制)表示
Dim ErrorAngle As Double
ErrorAngle = AngleSum - (PointNum - 2) * 180

'度(十进制)转化为秒(十进制)
ErrorSec = DegreeToSecond(ErrorAngle)

'检核角度闭合差是否超出限差
If Abs(ErrorSec) > 60 * Sqr(PointNum) Then
    MsgBox "角度闭合差超限！", vbCritical, "错误"
    Exit Sub
End If


'处理角度闭合差分配时四舍五入产生误差的情况
'计算改正后的转折角
For i = 1 To PointNum - 1
    RectifyAngle(i) = DMSToDegree(Angle(i)) + (-ErrorAngle / PointNum)
Next
RectifyAngle(PointNum) = DMSToDegree(Angle(PointNum)) - ErrorAngle + (ErrorAngle / PointNum) * (PointNum - 1)

'检验角度闭合差是否为0
Dim temp As Double
For i = 1 To PointNum
    temp = temp + RectifyAngle(i)
    RectifyAngle(i) = DegreeToDMS(RectifyAngle(i))   '度(十进制)转化为度，分，秒
Next
temp = (PointNum - 2) * 180 - DegreeToDMS(temp)



'二、坐标方位角推算
Azimuth(1) = DMSToDegree(StartAzimuth)
For i = 1 To PointNum
    If AngleDirection = True Then '转折角为右角
        Azimuth(i + 1) = Azimuth(i) + 180 - DMSToDegree(RectifyAngle(i))
    Else
        Azimuth(i + 1) = Azimuth(i) + DMSToDegree(RectifyAngle(i)) - 180
    End If
    If Azimuth(i + 1) > 360 Then Azimuth(i + 1) = Azimuth(i + 1) - 360
    If Azimuth(i + 1) < 0 Then Azimuth(i + 1) = Azimuth(i + 1) + 360
Next


'''坐标方位角计算检核
''If Abs(Azimuth(1) - Azimuth(PointNum + 1)) > 0.000001 Then
''    MsgBox "坐标方位角计算检核失败。", vbCritical, "错误"
''    Exit Sub
''End If

'换成度分秒形式
For i = 1 To PointNum + 1
    Azimuth(i) = DegreeToDMS(Azimuth(i))
Next

'三、坐标增量计算与增量闭合差调整
Dim DeltaXSum As Double, DeltaYSum As Double
Dim DistanceSum As Double
Dim tempRectDistX As Double, tempRectDistY As Double

DeltaXSum = 0: DeltaYSum = 0
DistanceSum = 0: ErrorDist = 0

For i = 1 To PointNum
    '度，分，秒转化为弧度后进行计算
    DeltaX(i) = Distance(i) * Cos(DMSToRadian(Azimuth(i)))
    DeltaY(i) = Distance(i) * Sin(DMSToRadian(Azimuth(i)))
    DeltaXSum = DeltaXSum + DeltaX(i)
    DeltaYSum = DeltaYSum + DeltaY(i)
    DistanceSum = DistanceSum + Distance(i)
Next

'计算导线全长相对闭合差
ErrorDist = Sqr(DeltaXSum ^ 2 + DeltaYSum ^ 2)
ErrorT = ErrorDist / DistanceSum
ErrorT = 1 / ErrorT
If ErrorT < 2000 Then
    MsgBox "导线全长相对闭合差为1/" & Int(ErrorT) & ",不合格！", vbCritical, "错误"
    Exit Sub
End If


'调整导线全长相对闭合差
For i = 1 To PointNum
    tempRectDistX = (-DeltaXSum) * Distance(i) / DistanceSum
    RectifyDeltaX(i) = DeltaX(i) + tempRectDistX
    tempRectDistY = (-DeltaYSum) * Distance(i) / DistanceSum
    RectifyDeltaY(i) = DeltaY(i) + tempRectDistY
Next


'四、导线点坐标推算
CoX(1) = StartX: CoY(1) = StartY
For i = 2 To PointNum + 1
    CoX(i) = CoX(i - 1) + RectifyDeltaX(i - 1)
    CoY(i) = CoY(i - 1) + RectifyDeltaY(i - 1)

Next

'坐标计算检核
If Abs(CoX(1) - CoX(PointNum + 1)) > 0.0001 Then
    MsgBox "X坐标计算检核失败。", vbCritical, "错误"
    Exit Sub
End If

If Abs(CoY(1) - CoY(PointNum + 1)) > 0.0001 Then
    MsgBox "Y坐标计算检核失败。", vbCritical, "错误"
    Exit Sub
End If

For i = 1 To PointNum
    DeltaX(i) = Format(DeltaX(i), "#.###")
    DeltaY(i) = Format(DeltaY(i), "#.###")
    RectifyDeltaX(i) = Format(RectifyDeltaX(i), "#.###")
    RectifyDeltaY(i) = Format(RectifyDeltaY(i), "#.###")
    
Next

For i = 1 To PointNum + 1
    CoX(i) = Format(CoX(i), "#.###")
    CoY(i) = Format(CoY(i), "#.###")
Next

End Sub



'以某控制点为中心绘等边三角形
Private Sub DrawTriangle(Picture As PictureBox, ByVal X As Double, ByVal Y As Double, _
                         Radius As Double, Optional OColor As ColorConstants)
Dim temp As Double
temp = Radius * Sqr(3) / 2

If IsMissing(OColor) Then OColor = vbRed

Picture.Line (X - temp, Y - Radius / 2)-(X, Y + Radius), OColor
Picture.Line (X + temp, Y - Radius / 2)-(X, Y + Radius), OColor
Picture.Line (X + temp, Y - Radius / 2)-(X - temp, Y - Radius / 2), OColor

End Sub

'根据导线点的坐标绘出控制点
Public Sub DrawSketchPoint(CoX() As Double, CoY() As Double, Picture As PictureBox, _
                           ByVal PSize As Double, Optional PColor As ColorConstants)

If IsMissing(PColor) Then PColor = vbRed

Dim i As Integer

Select Case TraverseType
    Case "ClosedTraverse"
        '画出第一个已知控制点
        DrawTriangle Picture, CoY(1), CoX(1), 2 * PSize, PColor
        
        '画出其它控制点
        For i = 2 To PointNum
            Picture.Circle (CoY(i), CoX(i)), PSize, PColor
            Picture.CurrentX = CoY(i)
            Picture.CurrentY = CoX(i)
            Picture.Print i
        Next

        '标注点名点
        For i = 1 To PointNum
            Picture.CurrentX = CoY(i)
            Picture.CurrentY = CoX(i)
            Picture.Print i
        Next
    
    Case "ConnectingTraverse"
        '画出四个已知控制点
        DrawTriangle Picture, CoY(1), CoX(1), 2 * PSize, PColor
        DrawTriangle Picture, CoY(2), CoX(2), 2 * PSize, PColor
        DrawTriangle Picture, CoY(PointNum + 1), CoX(PointNum + 1), 2 * PSize, PColor
        DrawTriangle Picture, CoY(PointNum + 2), CoX(PointNum + 2), 2 * PSize, PColor
        
        '画出其它控制点
        For i = 3 To PointNum
            Picture.Circle (CoY(i), CoX(i)), PSize, PColor
            Picture.CurrentX = CoY(i)
            Picture.CurrentY = CoX(i)
            Picture.Print i
        Next

        '标注点名点
        For i = 1 To PointNum + 2
            Picture.CurrentX = CoY(i)
            Picture.CurrentY = CoX(i)
            Picture.Print i
        Next
    
    Case "OpenTraverse"
    
    Case Else
End Select


End Sub

'****************
'高亮当前控制点
'****************
Private Sub DrawSketchHLPoint(CoX() As Double, CoY() As Double, ByVal PointID As Integer, Picture As PictureBox, _
                            ByVal PSize As Double, Optional PColor As ColorConstants, Optional HLColor As ColorConstants)

If IsMissing(PColor) Then PColor = vbRed
If IsMissing(HLColor) Then HLColor = vbYellow

Dim i As Integer

Select Case TraverseType
    Case "ClosedTraverse"