📄 frmmain.frm
字号:
Begin VB.Label lblCoY
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
Caption = "Y坐标(m)"
BeginProperty Font
Name = "黑体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 300
Index = 0
Left = 9240
TabIndex = 14
Top = 0
Width = 1095
End
Begin VB.Label lblBottom
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
Caption = "限差说明："
BeginProperty Font
Name = "黑体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 300
Left = 0
TabIndex = 13
Top = 960
Visible = 0 'False
Width = 9615
End
End
End
Begin VB.HScrollBar HScroll1
Height = 255
Left = 120
TabIndex = 4
Top = 8400
Visible = 0 'False
Width = 9255
End
Begin VB.CommandButton CmdGetForm
Caption = "生成表格"
Height = 375
Left = 10080
TabIndex = 2
Top = 8040
Width = 1455
End
Begin MSComDlg.CommonDialog CommonDg1
Left = 0
Top = 0
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 1
Top = 8790
Width = 11685
_ExtentX = 20611
_ExtentY = 661
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 4
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 6615
MinWidth = 6615
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 8334
EndProperty
EndProperty
End
Begin VB.PictureBox PictureMap
AutoRedraw = -1 'True
Height = 5055
Left = 120
ScaleHeight = 4995
ScaleWidth = 9435
TabIndex = 0
Top = 120
Width = 9495
End
Begin VB.Label Label2
BackColor = &H8000000E&
Height = 255
Left = 120
TabIndex = 31
Top = 8400
Width = 9255
End
Begin VB.Label Label1
BackColor = &H8000000E&
Height = 3255
Left = 9360
TabIndex = 30
Top = 5400
Width = 255
End
Begin VB.Line Line1
X1 = 0
X2 = 776
Y1 = 352
Y2 = 352
End
Begin VB.Label lblStationNum
AutoSize = -1 'True
Caption = "测站点个数"
Height = 195
Left = 10080
TabIndex = 3
Top = 7080
Width = 900
End
Begin VB.Menu MnuFile
Caption = "文件(&F)"
Begin VB.Menu MnuNewDataFile
Caption = "新建数据文件..."
End
Begin VB.Menu MnuImportDataFile
Caption = "导入数据文件..."
End
Begin VB.Menu MnuInputData
Caption = "输入数据..."
End
Begin VB.Menu deilp
Caption = "-"
End
Begin VB.Menu MnuExit
Caption = "退出"
End
End
Begin VB.Menu MnuSurvey
Caption = "测量(&S)"
Begin VB.Menu MnuAngleHorizontal
Caption = "转折角方向"
Begin VB.Menu MnuAngles
Caption = "右角"
Checked = -1 'True
Index = 1
End
Begin VB.Menu MnuAngles
Caption = "左角"
Index = 2
End
End
Begin VB.Menu puirfdew
Caption = "-"
End
Begin VB.Menu MnuTraverseCalculate
Caption = "导线计算"
End
End
Begin VB.Menu MnuResultManager
Caption = "成果管理(&M)"
Begin VB.Menu MnuPrecision
Caption = "测量精度..."
End
Begin VB.Menu MnuResultInfo
Caption = "成果表信息"
End
Begin VB.Menu MnuDistQuery
Caption = "边长查询"
End
Begin VB.Menu MnuCoQuery
Caption = "坐标查询"
End
End
Begin VB.Menu MnuOutput
Caption = "输出(&O)"
Begin VB.Menu MnuFigureCopy
Caption = "图形复制"
End
Begin VB.Menu TableCopy
Caption = "表格复制"
Visible = 0 'False
End
Begin VB.Menu MnuFigureSave
Caption = "图形保存..."
End
Begin VB.Menu TableSave
Caption = "表格保存..."
End
Begin VB.Menu MnuTableOutput
Caption = "表格输出..."
End
End
Begin VB.Menu MnuTool
Caption = "工具(&T)"
Begin VB.Menu MnuCoordinateChange
Caption = "坐标换算..."
End
Begin VB.Menu MnuAngleChange
Caption = "角度换算..."
End
Begin VB.Menu kuewwqafdg
Caption = "-"
End
Begin VB.Menu MnuOption
Caption = "选项..."
End
End
Begin VB.Menu MnuHelp
Caption = "帮助(&H)"
Begin VB.Menu MnuHelpContent
Caption = "内容..."
End
Begin VB.Menu MnuHelpAbout
Caption = "关于..."
End
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'导线控制点的总点数
Dim PointNum As Integer
'已知数据
Dim StartAzimuth As Double
Dim EndAzimuth As Double
Dim Angles() As Double
Dim StartX As Double
Dim StartY As Double
Dim EndX As Double
Dim EndY As Double
Dim Distances() As Double
''最后得到的坐标
'Public ResultX() As Double
'Public ResultY() As Double
Dim ErrorSec As Double
Dim RectifyAngle() As Double
Dim Azimuth() As Double
Dim DeltaX() As Double
Dim DeltaY() As Double
Dim ErrorT As Double
Dim ErrorDist As Double
Dim RectifyDeltaX() As Double
Dim RectifyDeltaY() As Double
'是否进行过选项设置
Public IfOptionSet As Boolean
'是否进行过导线计算
Public IfCalculate As Boolean
'导线类型
'ClosedTraverse '闭合导线
'ConnectingTraverse '附合导线
'OpenTraverse '支导线
Public TraverseType As String
'转折角的方向（true为右角,false为左角）
Dim AngleDirection As Boolean
'*************************
'附合导线测量函数
'*************************
'
'1、原始数据输入（必选项）
'Angle()输入的原始转折角--注意：是以度分秒形式输入（12.5632表示12度56分32秒）
'Distance()输入的原始边长
'StartAzimuth输入的起始边坐标方位角,以度分秒形式输入
'EndAzimuth输入的终止边坐标方位角,以度分秒形式输入
'StartX为起算点X坐标
'StartY为起算点Y坐标
'EndX为起算点X坐标
'EndY为起算点Y坐标
'AngleDirection为转折角方向
'2、导线坐标输出（必选项）
'CoX()导线点X坐标
'CoY()导线点Y坐标
'3、中间过程输出
'ErrorSec为角度闭合差
'RectifyAngle()改正后转折角-用度分秒形式
'Azimuth()各边的坐标方位角
'DeltaX()X的增量
'DeltaY()Y的增量
'ErrorDist导线全长闭合差
'RectifyDeltaX()改正后X的增量
'RectifyDeltaY()改正后Y的增量
'T导线全长相对闭合差
Sub ConnectingTraverse(Angle() As Double, Distance() As Double, _
ByVal StartAzimuth As Double, ByVal StartX As Double, ByVal StartY As Double, _
ByVal EndAzimuth As Double, ByVal EndX As Double, ByVal EndY 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 EndAzimuthSurvey As Double '终止边方位角的观测值
ReDim RectifyAngle(1 To PointNum)
ReDim Azimuth(1 To PointNum + 1)
ReDim DeltaX(1 To PointNum - 1)
ReDim DeltaY(1 To PointNum - 1)
ReDim RectifyDeltaX(1 To PointNum - 1)
ReDim RectifyDeltaY(1 To PointNum - 1)
ReDim CoX(1 To PointNum + 2)
ReDim CoY(1 To PointNum + 2)
'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
EndAzimuthSurvey = DMSToDegree(StartAzimuth)
If AngleDirection = True Then '右角
For i = 1 To PointNum
EndAzimuthSurvey = EndAzimuthSurvey + 180 - DMSToDegree(Angle(i))
If EndAzimuthSurvey > 360 Then EndAzimuthSurvey = EndAzimuthSurvey - 360
If EndAzimuthSurvey < 0 Then EndAzimuthSurvey = EndAzimuthSurvey + 360
Next
Else '左角
For i = 1 To PointNum
EndAzimuthSurvey = EndAzimuthSurvey - 180 + DMSToDegree(Angle(i))
If EndAzimuthSurvey > 360 Then EndAzimuthSurvey = EndAzimuthSurvey - 360
If EndAzimuthSurvey < 0 Then EndAzimuthSurvey = EndAzimuthSurvey + 360
Next
End If
'角度闭合差，用度(十进制)表示
'当用左角计算终止方位角时，改正数与ErrorAngle反号
'当用右角计算终止方位角时，改正数与ErrorAngle同号
Dim ErrorAngle As Double
If AngleDirection = True Then '右角
ErrorAngle = EndAzimuthSurvey - DMSToDegree(EndAzimuth)
ErrorAngle = -ErrorAngle
Else
ErrorAngle = EndAzimuthSurvey - DMSToDegree(EndAzimuth)
End If
'度(十进制)转化为秒(十进制)
ErrorSec = DegreeToSecond(ErrorAngle)
'检核角度闭合差是否超出限差
If Abs(ErrorSec) > 60 * Sqr(PointNum) Then
MsgBox "角度闭合差超限！", vbCritical, "错误"
Exit Sub
End If
'处理角度闭合差分配时四舍五入产生误差的情况
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -