frmmain.frm

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

        EndY = gDatas(PointNum + 2, 3)
        
        OptClosed.Value = False
        OptConnection.Value = True
        '生成表格
        Call GetForm(PointNum, True, 2)
        
        '将文件数据填入表格
        For i = 1 To PointNum
            lblAngle(i + 1).Caption = Angles(i)
            lblDist(i + 1).Caption = Distances(i)
            If lblDist(i + 1).Caption = "0" Then lblDist(i + 1).Caption = ""
        Next
        
        lblAzimuth(1).Caption = StartAzimuth
        lblAzimuth(PointNum + 1).Caption = EndAzimuth
        lblCoX(2).Caption = StartX
        lblCoY(2).Caption = StartY
        lblCoX(PointNum + 1).Caption = EndX
        lblCoY(PointNum + 1).Caption = EndY
        
        
    Case "OpenTraverse"
        str = "支导线"
        
    Case Else
End Select

TxtStationNum.Text = PointNum

OptClosed.Enabled = False
OptConnection.Enabled = False
TxtStationNum.Enabled = False
CmdGetForm.Enabled = False
PicContainer.Visible = True
lblBottom.Caption = "限差说明："

StatusBar1.Panels(1).Text = str & "：" & CommonDg1.FileName
StatusBar1.Panels(2).Text = ""
StatusBar1.Panels(3).Text = ""
StatusBar1.Panels(4).Text = ""

IfCalculate = False
PictureMap.Cls

End Sub

Private Sub MnuInputData_Click()
FrmDataInput.Show vbModal
End Sub

Private Sub MnuNewDataFile_Click()
'Shell
End Sub

Private Sub MnuOption_Click()
FrmOption.Show vbModal
End Sub

Private Sub MnuOutputFile_Click()
OutputDataResult "c:\a.txt", PointNum
End Sub

Private Sub MnuPrecision_Click()

Dim strErrorDist As String

If ErrorDist > 0 And ErrorDist < 1 Then
    strErrorDist = "0" & Format(ErrorDist, "#.##")

ElseIf ErrorDist > -1 And ErrorDist < 0 Then
    strErrorDist = "-0" & Abs(Format(ErrorDist, "#.##"))
Else
    strErrorDist = Format(ErrorDist, "#.##")
End If


MsgBox "角度闭合差:  " & ErrorSec & "秒" & vbCrLf _
        & "导线全长闭合差(f):  " & strErrorDist & "米" & vbCrLf _
        & "导线全长相对闭合差(T):  1/" & Int(ErrorT), vbOKOnly, "测量精度"
End Sub

Private Sub MnuResultInfo_Click()

End Sub

Private Sub MnuTableOutput_Click()

End Sub

Private Sub MnuTraverseCalculate_Click()
Select Case TraverseType
    Case "ClosedTraverse"
        ClosedTraverse Angles(), Distances(), StartAzimuth, _
                                StartX, StartY, AngleDirection, _
                                ErrorSec, RectifyAngle(), Azimuth(), _
                                DeltaX(), DeltaY(), ErrorDist, _
                                RectifyDeltaX(), RectifyDeltaY(), _
                                ResultX(), ResultY(), ErrorT

    Case "ConnectingTraverse"
        ConnectingTraverse Angles(), Distances(), StartAzimuth, _
                                StartX, StartY, EndAzimuth, EndX, EndY, AngleDirection, _
                                ErrorSec, RectifyAngle(), Azimuth(), _
                                DeltaX(), DeltaY(), ErrorDist, _
                                RectifyDeltaX(), RectifyDeltaY(), _
                                ResultX(), ResultY(), ErrorT
    
    Case "OpenTraverse"
    
End Select

PictureMap.Cls

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

If ErrorT < 2000 Then
    'MsgBox "导线全长相对闭合差为1/" & Int(ErrorT) & ",不合格！", vbCritical, "错误"
    Exit Sub
End If

Dim LineColor As ColorConstants
Dim CtlPSize As Double
Dim PointColor As ColorConstants
Dim MarginDist As Double

'为了清空资源,防止内存泄露
If IfOptionSet = True Then
    LineColor = FrmOption.picColor(1).BackColor
    CtlPSize = CDbl(FrmOption.TxtCtlPSize.Text)
    PointColor = FrmOption.picColor(0).BackColor
    MarginDist = CDbl(FrmOption.TxtMarginDist.Text)
Else
    LineColor = vbBlack
    CtlPSize = 2.5
    PointColor = vbRed
    MarginDist = 1.3
End If

Dim i As Integer
Dim str As String
Dim SumDist As Double, SumDeltaX As Double, SumDeltaY As Double
Dim SumRectDeltaX As Double, SumRectDeltaY As Double

Select Case TraverseType
    Case "ClosedTraverse"
        DrawSketchLine ResultX(), ResultY(), True, PictureMap, MarginDist, LineColor
        DrawSketchPoint ResultX(), ResultY(), PictureMap, CtlPSize, PointColor
        
        '将数据填入表格
        For i = 1 To PointNum
            lblRectAngle(i + 1) = RectifyAngle(i)
            lblDeltaX(i) = DeltaX(i)
            lblDeltaY(i) = DeltaY(i)
            lblRectDeltaX(i) = RectifyDeltaX(i)
            lblRectDeltaY(i) = RectifyDeltaY(i)
        Next
        For i = 1 To PointNum + 1
            lblAzimuth(i) = Azimuth(i)
            lblCoX(i) = ResultX(i)
            lblCoY(i) = ResultY(i)
        Next
        For i = 1 To PointNum
            SumDist = SumDist + Distances(i)
            SumDeltaX = SumDeltaX + DeltaX(i)
            SumDeltaY = SumDeltaY + DeltaY(i)
            SumRectDeltaX = SumRectDeltaX + RectifyDeltaX(i)
            SumRectDeltaY = SumRectDeltaY + RectifyDeltaY(i)
        Next
        lblAzimuth(PointNum + 2) = "∑"
        lblDist(PointNum + 2) = SumDist
        lblDeltaX(PointNum + 2) = Format(SumDeltaX, "#.##")
        lblDeltaY(PointNum + 2) = Format(SumDeltaY, "#.##")
        lblRectDeltaX(PointNum + 2) = Format(SumRectDeltaX, "#.##")
        lblRectDeltaY(PointNum + 2) = Format(SumRectDeltaY, "#.##")
        
        str = "限差说明：   角度闭合差(秒)=" & ErrorSec & "；   "
        str = str & "坐标增量闭合差(米)=" & Format(ErrorDist, "#.##") & "；   "
        str = str & "全长相对闭合差=1/" & Int(ErrorT)
        lblBottom.Caption = str
        
    Case "ConnectingTraverse"
        DrawSketchLine ResultX(), ResultY(), False, PictureMap, MarginDist, LineColor
        DrawSketchPoint ResultX(), ResultY(), PictureMap, CtlPSize, PointColor
        
        '将数据填入表格
        For i = 1 To PointNum
            lblRectAngle(i + 1) = RectifyAngle(i)
            lblCoX(i + 1) = ResultX(i + 1)
            lblCoY(i + 1) = ResultY(i + 1)
        Next
        For i = 1 To PointNum + 1
            lblAzimuth(i) = Azimuth(i)
        Next
        For i = 2 To PointNum
            lblDeltaX(i) = DeltaX(i - 1)
            lblDeltaY(i) = DeltaY(i - 1)
            lblRectDeltaX(i) = RectifyDeltaX(i - 1)
            lblRectDeltaY(i) = RectifyDeltaY(i - 1)
        Next
        For i = 1 To PointNum - 1
            SumDist = SumDist + Distances(i)
            SumDeltaX = SumDeltaX + DeltaX(i)
            SumDeltaY = SumDeltaY + DeltaY(i)
            SumRectDeltaX = SumRectDeltaX + RectifyDeltaX(i)
            SumRectDeltaY = SumRectDeltaY + RectifyDeltaY(i)
        Next
        lblAzimuth(PointNum + 2) = "∑"
        lblDist(PointNum + 2) = SumDist
        lblDeltaX(PointNum + 2) = Format(SumDeltaX, "#.##")
        lblDeltaY(PointNum + 2) = Format(SumDeltaY, "#.##")
        lblRectDeltaX(PointNum + 2) = Format(SumRectDeltaX, "#.##")
        lblRectDeltaY(PointNum + 2) = Format(SumRectDeltaY, "#.##")
        
        str = "限差说明：   角度闭合差(秒)=" & ErrorSec & "；   "
        str = str & "坐标增量闭合差(米)=" & Format(ErrorDist, "#.##") & "；   "
        str = str & "全长相对闭合差=1/" & Int(ErrorT)
        lblBottom.Caption = str
        
    Case Else
        
End Select




IfCalculate = True


End Sub

Private Sub MnuTraverses_Click(Index As Integer)
Dim i As Integer
For i = 1 To 3
    MnuTraverses(i).Checked = False
Next

MnuTraverses(Index).Checked = True

''Select Case Index
''    Case 1: TraverseType = ClosedTraverses
''    Case 2: TraverseType = ConnectingTraverses
''    Case 3: TraverseType = OpenTraverses
''
''End Select

End Sub

Private Sub PictureMap_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

'判断是否已进行过导线计算
If IfCalculate = False Then
    Exit Sub
End If


StatusBar1.Panels(2).Text = "X坐标:" & Format(Y, "#.###")
StatusBar1.Panels(3).Text = "Y坐标:" & Format(X, "#.###")


Dim IfPickL As Boolean
Dim i As Integer

Dim SnapDist As Double
Dim LineColor As ColorConstants
Dim CtlPSize As Double
Dim PointColor As ColorConstants
Dim HLPointColor As ColorConstants
Dim MarginDist As Double

'为了清空资源,防止内存泄露
If IfOptionSet = True Then
    SnapDist = CDbl(FrmOption.TxtSnapDist.Text)
    LineColor = FrmOption.picColor(1).BackColor
    CtlPSize = CDbl(FrmOption.TxtCtlPSize.Text)
    PointColor = FrmOption.picColor(0).BackColor
    HLPointColor = FrmOption.picColor(2).BackColor
    MarginDist = CDbl(FrmOption.TxtMarginDist.Text)
Else
    SnapDist = 3
    LineColor = vbBlack
    CtlPSize = 2.5
    PointColor = vbRed
    HLPointColor = vbCyan
    MarginDist = 1.3
End If


Select Case TraverseType
    Case "ClosedTraverse"
        For i = 1 To PointNum
            If FrmOption.IfShowGrid = True Then
                With FrmOption
                    .ShowGrid CDbl(.TextXco.Text), CDbl(.TextYco.Text), CInt(.TextRowNums.Text), _
                        CInt(.TextColNums.Text), .intScale, .PicGridColor.BackColor, PictureMap
                End With
            End If
            
            '判断当前鼠标点与导线点的距离，从而拾取导线点
            If Sqr((X - ResultY(i)) ^ 2 + (Y - ResultX(i)) ^ 2) < SnapDist Then
                DrawSketchLine ResultX(), ResultY(), True, PictureMap, MarginDist, LineColor
                DrawSketchHLPoint ResultX(), ResultY(), i, PictureMap, _
                                  CtlPSize, PointColor, HLPointColor
                StatusBar1.Panels(4).Text = "当前点：" & i
                Exit For
            Else
                
                '判断当前鼠标点与导线边的距离，从而拾取导线边
                IfPickL = IfPickLine(ResultY(i), ResultX(i), ResultY(i + 1), ResultX(i + 1), X, Y, SnapDist)
                If IfPickL = True Then
                    DrawSketchHLLine ResultX(), ResultY(), True, i, PictureMap, LineColor, HLPointColor
                    DrawSketchPoint ResultX(), ResultY(), PictureMap, CtlPSize, PointColor
                    If i <> PointNum Then
                        StatusBar1.Panels(4).Text = "当前边：" & i & "-" & (i + 1)
                    Else
                        StatusBar1.Panels(4).Text = "当前边：" & i & "-" & 1
                    End If
                    Exit For
                Else
                    DrawSketchLine ResultX(), ResultY(), True, PictureMap, MarginDist, LineColor
                    DrawSketchPoint ResultX(), ResultY(), PictureMap, CtlPSize, PointColor
                    StatusBar1.Panels(4).Text = ""
                    
                End If
                
            
            End If
        Next
    
    Case "ConnectingTraverse"
    
        For i = 1 To PointNum + 2
            If FrmOption.IfShowGrid = True Then
                With FrmOption
                    .ShowGrid CDbl(.TextXco.Text), CDbl(.TextYco.Text), CInt(.TextRowNums.Text), _
                        CInt(.TextColNums.Text), .intScale, .PicGridColor.BackColor, PictureMap
                End With
            End If
            
            '判断当前鼠标点与导线点的距离，从而拾取导线点
            If Sqr((X - ResultY(i)) ^ 2 + (Y - ResultX(i)) ^ 2) < SnapDist Then
                DrawSketchLine ResultX(), ResultY(), False, PictureMap, MarginDist, LineColor
                DrawSketchHLPoint ResultX(), ResultY(), i, PictureMap, _
                                  CtlPSize, PointColor, HLPointColor
                StatusBar1.Panels(4).Text = "当前点：" & i
                Exit For
            Else
                If i <> PointNum + 2 Then
                    '判断当前鼠标点与导线边的距离，从而拾取导线边
                    IfPickL = IfPickLine(ResultY(i), ResultX(i), ResultY(i + 1), ResultX(i + 1), X, Y, SnapDist)
                    If IfPickL = True Then
                        DrawSketchHLLine ResultX(), ResultY(), False, i, PictureMap, LineColor, HLPointColor
                        DrawSketchPoint ResultX(), ResultY(), PictureMap, CtlPSize, PointColor
                        StatusBar1.Panels(4).Text = "当前边：" & i & "-" & (i + 1)
                        Exit For
                    Else
                        DrawSketchLine ResultX(), ResultY(), False, PictureMap, MarginDist, LineColor
                        DrawSketchPoint ResultX(), ResultY(), PictureMap, CtlPSize, PointColor
                        StatusBar1.Panels(4).Text = ""
    
                    End If
                End If
                
            End If
        Next
    
    Case "OpenTraverse"
    
    Case Else
End Select


End Sub

Private Sub PictureMap_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

'判断是否已进行过导线计算
If IfCalculate = False Then
    Exit Sub
End If

Dim i As Integer
Dim IfPickL As Boolean
Dim SnapDist As Double

'为了清空资源,防止内存泄露
If IfOptionSet = True Then
    SnapDist = CDbl(FrmOption.TxtSnapDist.Text)
Else
    SnapDist = 3
End If

Select Case TraverseType
    Case "ClosedTraverse"
        For i = 1 To PointNum
            If Sqr((X - ResultY(i)) ^ 2 + (Y - ResultX(i)) ^ 2) < SnapDist Then