frmmain.frm

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

        '已知起算控制点为当前点
        If PointID = 1 Then
            '画出第一个已知控制点
            DrawTriangle Picture, CoY(1), CoX(1), 2 * PSize, HLColor
            '画出其它控制点
            For i = 2 To PointNum
                Picture.Circle (CoY(i), CoX(i)), PSize, PColor
            Next
        
        Else
            '画出第一个已知控制点
            DrawTriangle Picture, CoY(1), CoX(1), 2 * PSize, PColor
            '画出其它控制点
            For i = 2 To PointNum
                If i <> PointID Then Picture.Circle (CoY(i), CoX(i)), PSize, PColor
            Next
        
            Picture.Circle (CoY(PointID), CoX(PointID)), PSize, HLColor
            
        End If
        
        '标注点名点
        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)
        Next

        If PointID = 1 Or PointID = 2 Or PointID = PointNum + 1 Or PointID = PointNum + 2 Then
            DrawTriangle Picture, CoY(PointID), CoX(PointID), 2 * PSize, HLColor
        Else
            Picture.Circle (CoY(PointID), CoX(PointID)), PSize, HLColor
        End If

        '标注点名点
        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

'**************************
'根据控制点的坐标定出地形图的范围，并绘出各边长
'**************************
'关键步骤：根据实际坐标定出地形图的范围
'CoX()计算的导线点X坐标
'CoY()计算的导线点Y坐标
'IsClose是否是闭合导线
'MarginDist页边空白间距比例（应大于1）
'OColor绘制颜色
Public Sub DrawSketchLine(CoX() As Double, CoY() As Double, ByVal IsClose As Boolean, Picture As PictureBox, _
                          Optional MarginDist As Double, Optional OColor As ColorConstants)

'获取测站点个数
Dim PointCoX As Integer
Dim PointCoY As Integer

PointCoX = UBound(CoX, 1) - LBound(CoX, 1) + 1
PointCoY = UBound(CoY, 1) - LBound(CoY, 1) + 1
If PointCoX <> PointCoX Then
    MsgBox "X坐标点与Y坐标点个数不相等。", vbInformation, "提示"
    Exit Sub
End If

Dim i As Integer

'图像框中心点的坐标位置
Dim CenterX As Double
Dim CenterY As Double

Dim MaxX As Double, MinX As Double
Dim MaxY As Double, MinY As Double
MaxX = CoX(1): MinX = CoX(1)
MaxY = CoY(1): MinY = CoY(1)

For i = 2 To PointCoX
    If MaxX < CoX(i) Then MaxX = CoX(i)
    If MinX > CoX(i) Then MinX = CoX(i)
    If MaxY < CoY(i) Then MaxY = CoY(i)
    If MinY > CoY(i) Then MinY = CoY(i)
Next

CenterX = (MaxX + MinX) / 2
CenterY = (MaxY + MinY) / 2


Dim HeightLength As Double
Dim WidthLength As Double

If (MaxX - MinX) / (MaxY - MinY) > CDbl(Picture.Height / Picture.Width) Then '显示以高度为基准
    HeightLength = ((MaxX - MinX) / 2) * MarginDist
    WidthLength = HeightLength * Picture.Width / Picture.Height
Else        '显示以宽度为基准（高度比宽度大）
    WidthLength = ((MaxY - MinY) / 2) * MarginDist
    HeightLength = WidthLength * Picture.Height / Picture.Width
End If


'根据实际坐标定出地形图的范围
'#######
Picture.ScaleMode = vbUser
Picture.Scale (CenterY - WidthLength, CenterX + HeightLength)-(CenterY + WidthLength, CenterX - HeightLength)

If IsMissing(OColor) Then OColor = vbBlack

If IsClose = True Then  '闭合

    For i = 2 To PointCoX
        Picture.Line (CoY(i), CoX(i))-(CoY(i - 1), CoX(i - 1)), OColor
    Next
    Picture.Line (CoY(1), CoX(1))-(CoY(PointCoX), CoX(PointCoX)), OColor
Else    '不闭合
    
    For i = 2 To PointCoX
        Picture.Line (CoY(i), CoX(i))-(CoY(i - 1), CoX(i - 1)), OColor
    Next

End If
End Sub

'**************************
'高亮绘出当前导线边
'**************************
Private Sub DrawSketchHLLine(CoX() As Double, CoY() As Double, ByVal IsClose As Boolean, ByVal PointID As Integer, _
                            Picture As PictureBox, Optional OColor As ColorConstants, Optional HLColor As ColorConstants)

If IsMissing(OColor) Then OColor = vbBlack
If IsMissing(HLColor) Then HLColor = vbYellow

'获取测站点个数
Dim tPointNum As Integer
tPointNum = UBound(CoX, 1) - LBound(CoX, 1)

Dim i As Integer

If IsClose = True Then  '闭合
    '画出各条边
    For i = 1 To tPointNum
        If i <> PointID Then
            If i <> tPointNum Then
                Picture.Line (CoY(i), CoX(i))-(CoY(i + 1), CoX(i + 1)), OColor
            Else '绘到最后一条边
                Picture.Line (CoY(i), CoX(i))-(CoY(1), CoX(1)), OColor
            End If
        Else    '绘当前高亮边
            If i <> tPointNum Then
                Picture.Line (CoY(i), CoX(i))-(CoY(i + 1), CoX(i + 1)), HLColor
            Else '绘到最后一条边
                Picture.Line (CoY(i), CoX(i))-(CoY(1), CoX(1)), HLColor
            End If
        
        End If
    Next
    
Else
    '画出各条边
    For i = 1 To tPointNum
        If i <> PointID Then
            Picture.Line (CoY(i), CoX(i))-(CoY(i + 1), CoX(i + 1)), OColor
        Else    '绘当前高亮边
            Picture.Line (CoY(i), CoX(i))-(CoY(i + 1), CoX(i + 1)), HLColor
        End If
    Next
    
End If
End Sub


'****************
'是否拾取当前线段
'****************
'X1,Y1：第一个点的X，Y坐标
'X2,Y2：第二个点的X，Y坐标
'X,Y：当前鼠标点的X，Y坐标
'PickDist拾取的捕捉距离
'
Private Function IfPickLine(ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, _
                            ByVal X As Double, ByVal Y As Double, Optional ByVal PickDist As Integer) As Boolean

'斜率KB(与所绘线段垂直的直线)
Dim KB As Single

'截距1(过拾取线段起点，并与拾取线段垂直的直线的截距)
Dim b1 As Single
'截距2(过拾取线段终点，并与拾取线段垂直的直线的截距)
Dim b2 As Single
'截距3(过当前鼠标点，并与拾取线段垂直的直线的截距)
Dim b0 As Single
Dim maxb As Single, minb As Single
    
'计算相关斜率和最大最小值
KB = (-1) * (X1 - X2) / (Y1 - Y2)
b1 = Y1 - KB * X1
b2 = Y2 - KB * X2

If b1 > b2 Then
    maxb = b1
    minb = b2
Else
    maxb = b2
    minb = b1
End If

b0 = Y - KB * X

If IsMissing(PickDist) Then PickDist = 3

Dim fz As Single, fm As Single
Dim aaa As Single

'1、首先判断点是否在区间内
If b0 > minb And b0 < maxb Then

    '2、再判断点是否在半径范围内
    fz = (Y1 - Y2) * X - (X1 - X2) * Y - (Y1 - Y2) * X1 + (X1 - X2) * Y1
    fm = (X1 - X2) * (X1 - X2) + (Y1 - Y2) * (Y1 - Y2)

    aaa = Abs(fz) / Sqr(fm)

    If aaa <= PickDist Then
        IfPickLine = True

    Else
        IfPickLine = False
    End If

Else
    IfPickLine = False

End If

End Function


Private Sub Form_Load()

PictureMap.BackColor = vbWhite
IfOptionSet = False
IfCalculate = False
AngleDirection = True
Me.Icon = LoadPicture(App.Path & "\mainico.ico")

PicContainer.BorderStyle = 0

OptClosed.Enabled = False
OptConnection.Enabled = False
TxtStationNum.Enabled = False
CmdGetForm.Enabled = False

End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim i As Integer
'For i = 1 To PointNum + 1
'    Set ResultX(i) = Nothing
'    Set ResultY(i) = Nothing
'Next

End Sub

Private Sub HScroll1_Change()
PicContainer.Left = -HScroll1.Value
End Sub

Private Sub HScroll1_Scroll()
PicContainer.Left = -HScroll1.Value
End Sub

Private Sub MnuAngleChange_Click()
FrmAngleChange.Show vbModal
End Sub

Private Sub MnuAngles_Click(Index As Integer)
Dim i As Integer
For i = 1 To 2
    MnuAngles(i).Checked = False
Next

MnuAngles(Index).Checked = True

Select Case Index
    Case 1: AngleDirection = True
    Case 2: AngleDirection = False
End Select


End Sub


Private Sub MnuCoordinateChange_Click()
FrmCoordinateChange.Show vbModal
End Sub

Private Sub MnuExit_Click()
Unload Me
End Sub


Private Sub MnuFigureCopy_Click()
Clipboard.Clear
Clipboard.SetData PictureMap.Image
End Sub

Private Sub MnuHelpAbout_Click()
frmAbout.Show vbModal
End Sub


Private Sub MnuImportDataFile_Click()
'打开数据文件
On Error Resume Next
CommonDg1.DialogTitle = "打开测量数据"
CommonDg1.Filter = "DataFiles(*.dat,*.txt)|*.dat;*.txt"
CommonDg1.InitDir = App.Path
CommonDg1.ShowOpen

If Err = 32755 Then
  On Error GoTo 0
  Exit Sub
End If

'文本文件的头行与各行数据
Dim gHeader() As String, gDatas() As Double
'文本文件的行数和列数
Dim gRowsNum As Integer, gColsNum As Integer
ReadTxtFile CommonDg1.FileName, vbTab, gRowsNum, TraverseType, gDatas()

Dim i As Integer
Dim str As String
Select Case TraverseType
    Case "ClosedTraverse"
        str = "闭合导线"
        '由文件获得已知数据
        PointNum = gRowsNum - 3 '除去第一行导线类型标志行,第二行字段行和最后一行起算数据行
        
        ReDim Angles(1 To PointNum)
        ReDim Distances(1 To PointNum)
        
        For i = 1 To PointNum
            Angles(i) = gDatas(i, 2)
            Distances(i) = gDatas(i, 3)
        Next
        
        StartAzimuth = gDatas(PointNum + 1, 1)
        StartX = gDatas(PointNum + 1, 2)
        StartY = gDatas(PointNum + 1, 3)
        
        OptClosed.Value = True
        OptConnection.Value = False
        
        '生成表格
        Call GetForm(PointNum, True, 1)
        
        '将文件数据填入表格
        For i = 1 To PointNum
            lblAngle(i + 1) = Angles(i)
            lblDist(i) = Distances(i)
        Next
        lblAzimuth(1).Caption = StartAzimuth
        lblCoX(1).Caption = StartX
        lblCoY(1).Caption = StartY
        
        
    Case "ConnectingTraverse"
        str = "附合导线"
        PointNum = gRowsNum - 4
        
        ReDim Angles(1 To PointNum)
        ReDim Distances(1 To PointNum)
        
        For i = 1 To PointNum
            Angles(i) = gDatas(i, 2)
            Distances(i) = gDatas(i, 3)
        Next
        
        StartAzimuth = gDatas(PointNum + 1, 1)
        StartX = gDatas(PointNum + 1, 2)
        StartY = gDatas(PointNum + 1, 3)
        EndAzimuth = gDatas(PointNum + 2, 1)
        EndX = gDatas(PointNum + 2, 2)