📄 附合导线平差主窗体.frm
字号:
frmMain.Caption = frmMain.Caption + "(" + CommonDialog1.FileName + ")"
MSFlexGrid1.Cols = 5
If MSFlexGrid1.Rows > 2 Then
For i = MSFlexGrid1.Rows - 1 To 2 Step -1
MSFlexGrid1.RemoveItem (i)
Next i
End If
For i = 1 To 4
With MSFlexGrid1
.TextMatrix(1, i) = ""
IntCount = 0
KCount = 1
End With
Next i
MSFlexGrid1.col = 0
MSFlexGrid1.row = 0
MSFlexGrid1.ColSel = 4
MSFlexGrid1.FontWidth = 7
For i = 0 To 4
MSFlexGrid1.ColAlignment(i) = 4
Next i
MSFlexGrid1.ColWidth(0) = 300
MSFlexGrid1.ColWidth(1) = 1200
MSFlexGrid1.ColWidth(2) = 1400
MSFlexGrid1.ColWidth(3) = 2200
MSFlexGrid1.ColWidth(4) = 1600
MSFlexGrid1.col = 1
MSFlexGrid1.row = 0
MSFlexGrid1.ColSel = 4
MSFlexGrid1.Clip = "测站编号" & Chr(9) & "测站点名" & Chr(9) & "观测角度(o ′″)" & Chr(9) & "观测边长(m)"
Open CommonDialog1.FileName For Input As #1
Input #1, mm, ma, mb
For i = 1 To 2
Line Input #1, InputData
InputData = LTrim(InputData)
j = InStr(InputData, " ")
PointHao(i) = Val(Left(InputData, j - 1))
InputData = LTrim(Mid(InputData, j + 1))
j = InStr(InputData, " ")
PointName(i) = RTrim(Left(InputData, j - 1))
InputData = LTrim(Mid(InputData, j + 1))
j = InStr(InputData, " ")
xx(i) = Val(Left(InputData, j - 1))
InputData = LTrim(Mid(InputData, j + 1))
j = InStr(InputData, " ")
yy(i) = Val(Left(InputData, j - 1))
InputData = Trim(Mid(InputData, j + 1))
aa(i) = Val(InputData)
Next i
frmYizhiShuju.Text1.Text = Trim(str$(mm))
If (ma >= 0.01) And (ma < 1) Then
frmYizhiShuju.Text2.Text = "0" + Trim(str$(ma))
Else
frmYizhiShuju.Text2.Text = Trim(str$(ma))
End If
If (mb >= 0.01) And (mb < 1) Then
frmYizhiShuju.Text13.Text = "0" + Trim(str$(mb))
Else
frmYizhiShuju.Text13.Text = Trim(str$(mb))
End If
frmYizhiShuju.Text3.Text = Trim(str$(PointHao(1)))
frmYizhiShuju.Text4.Text = Trim(PointName(1))
frmYizhiShuju.Text5.Text = xx(1)
frmYizhiShuju.Text6.Text = yy(1)
frmYizhiShuju.Text7.Text = aa(1)
frmYizhiShuju.Text8.Text = Trim(str$(PointHao(2)))
frmYizhiShuju.Text9.Text = Trim(PointName(2))
frmYizhiShuju.Text10.Text = xx(2)
frmYizhiShuju.Text11.Text = yy(2)
frmYizhiShuju.Text12.Text = aa(2)
frmYizhiShuju.Visible = True
frmYizhiShuju.Visible = False
IntCount = 0
Do While Not EOF(1)
IntCount = IntCount + 1
With InputDat(IntCount)
Line Input #1, InputData
j = InStr(LTrim(InputData), " ")
.ICount = Val(Left(InputData, j - 1))
InputData = LTrim(Mid(InputData, j + 1))
j = InStr(InputData, " ")
.PiontName = Left(InputData, j - 1)
InputData = LTrim(Mid(InputData, j + 1))
j = InStr(InputData, " ")
.Guancejiao = Val(Left(InputData, j - 1))
InputData = Trim(Mid(InputData, j + 1))
.Bianchang = Val(InputData)
End With
Loop
Close #1
If InputDat(IntCount).Bianchang <> -1 Then
msg = "非法的数据输入！" & Chr(13) & Chr(10) & "请检查输入数据"
msg = MsgBox(msg, vbCritical + vbOKOnly, "出错提示")
If msg = vbOK Then
mnuDataOutput.Enabled = False
mnuDataInput.Enabled = False
Exit Sub
End If
End If
KCount = IntCount
i = 1
Do While i <= IntCount
With InputDat(i)
If i = 1 Then
MSFlexGrid1.col = 1
MSFlexGrid1.row = 1
MSFlexGrid1.ColSel = 4
MSFlexGrid1.Clip = .ICount & Chr(9) & .PiontName & Chr(9) & .Guancejiao & Chr(9) & .Bianchang
Else
If .Bianchang <= 0 Then
MSFlexGrid1.AddItem Chr(9) & .ICount & Chr(9) & .PiontName & Chr(9) & .Guancejiao
Else
MSFlexGrid1.AddItem Chr(9) & .ICount & Chr(9) & .PiontName & Chr(9) & .Guancejiao & Chr(9) & .Bianchang
End If
End If
i = i + 1
End With
Loop
bool = True
mnuDataInput.Enabled = True
'Exit Sub
ErrHandler:
Exit Sub
End Sub
Private Sub mnuFileSave_Click()
Dim Sum As Integer, i As Integer
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
CommonDialog1.FileName = "Default.TXT"
CommonDialog1.DefaultExt = "TXT"
CommonDialog1.Filter = "All files(*.*)|*.*|Text_Files(*.TXT)|*.TXT"
CommonDialog1.Action = 2
Open CommonDialog1.FileName For Output As #1
Print #1, mm; Spc(1); ma; Spc(1); Format(mb, "0.0")
'Print #1, kk
For i = 1 To 2
Print #1, PointHao(i); Spc(1); PointName(i); Spc(1); xx(i); Spc(1); yy(i); Spc(1); aa(i)
Next i
Sum = 0
i = 1
Do While i <= KCount
If Len(Trim(MSFlexGrid1.TextMatrix(i, 1))) <> 0 Then
Sum = Sum + 1
End If
i = i + 1
Loop
IntCount = Sum
For i = 1 To Sum
With InputDat(i)
.ICount = Val(Trim(MSFlexGrid1.TextMatrix(i, 1)))
.PiontName = MSFlexGrid1.TextMatrix(i, 2)
.Guancejiao = Val(Trim(MSFlexGrid1.TextMatrix(i, 3)))
.Bianchang = Val(Trim(MSFlexGrid1.TextMatrix(i, 4)))
End With
Next i
InputDat(IntCount).Bianchang = -1
For i = 1 To Sum
With InputDat(i)
Print #1, Trim(.ICount); Spc(1); Trim(.PiontName); Spc(1); Trim(.Guancejiao); Spc(1); Trim(.Bianchang)
End With
Next i
Close #1
ErrHandler:
Exit Sub
End Sub
Private Sub mnuFileSaveAs_Click()
mnuFileSave_Click
End Sub
Private Sub mnuOutputTxt_Click()
Dim strOutputFileName As String
Dim j As Integer
'Debug.Print StrFilename
j = InStr(StrFilename, ".")
strOutputFileName = Left$(StrFilename, j) + "out"
' Debug.Print strOutputFileName
Open strOutputFileName For Output As #1
Print #1, Spc(30); "平差报告"
Print #1, " "
Print #1, "m0="; Format(m0, "#.#"); "″"
Print #1, Spc(25); "平差后点边角值"
Print #1, "点号 点名 边平差值 坐标方位角平差值 坐标平差值/m"
Print #1, " /m ( o )(′)(″) X Y"
For i = 1 To IntCount
With ZBJG(i)
If i < IntCount Then
Print #1, Tab(1); InputDat(i).ICount; Tab(7); InputDat(i).PiontName; Tab(15); Format(s(i), "####.0000"); Tab(29); Format(DuDFM(.a), "###.000000"); Tab(46); Format(.x, "######.0000"); Tab(59); Format(.y, "######.0000")
Else
Print #1, Tab(1); InputDat(i).ICount; Tab(7); InputDat(i).PiontName; Tab(46); Format(.x, "######.0000"); Tab(59); Format(.y, "######.0000")
End If
End With
Next i
Print #1, " "
Print #1, " "
Print #1, Tab(25); "未知点误差椭圆和坐标误差"
Print #1, Tab(0); "点号"; Tab(6); "点名"; Tab(14); "A(dms)"; Tab(24); "E(mm)"; Tab(32); "F(mm)"; Tab(40); "M(mm)"; Tab(48); "MX(mm)"; Tab(56); "MY(mm)"; Tab(64); "M(mm)"
For i = 2 To IntCount - 1
With ZBJG(i)
Print #1, Tab(1); InputDat(i).ICount; Tab(7); InputDat(i).PiontName; Tab(16); Format(.Q, "###.0000"); Tab(28); Format(.E, "0.00"); Tab(36); Format(.F, "0.00"); Tab(44); Format(.m, "0.00"); Tab(52); Format(.mx, "0.00"); Tab(60); Format(.my, "0.00"); Tab(68); Format(.m, "0.00")
End With
Next i
Print #1, " "
Print #1, " "
Print #1, Tab(30); "点间相对误差"
Print #1, Tab(3); "边号"; Tab(13); "A(dms)"; Tab(24); "E(mm)"; Tab(33); "F(mm)"; Tab(42); "T(dms)"; Tab(53); "S(m)"; Tab(61); "MT(s)"; Tab(69); "MS(mm)"; Tab(78); "MS/S=1/"
For i = 1 To IntCount - 1
With Wzdty(i)
Print #1, Tab(1); Format(InputDat(i).ICount, "##0"); Tab(4); "--"; Tab(7); Format(InputDat(i + 1).ICount, "##0"); Tab(14); Format(.Q, "###.0000"); Tab(25); Format(.E, "###.0000"); Tab(34); Format(.F, "###.0000"); Tab(43); Format(.a, "###.0000"); Tab(54); Format(.s, "####.0"); Tab(63); Format(.ma, "##.00"); Tab(71); Format(.Ms, "##.00"); Tab(80); Format(.MsS, "######")
End With
Next i
Close #1
End Sub
Private Sub mnuVPCJG_Click()
frmXianshiJG.Visible = True
mnuOutJG.Enabled = True
mnuOutputTxt.Enabled = True
End Sub
Private Sub mnuVTuoyuan_Click()
mnuOutJG.Enabled = True
mnuOutputTxt.Enabled = True
frmHuaTuoYuan.Show
End Sub
Private Sub MSFlexGrid1_DblClick()
'Show Textbox for Input
If MSFlexGrid1.row > 0 Then
m_ActiveCell.row = MSFlexGrid1.row
m_ActiveCell.col = MSFlexGrid1.col
With txtEdit
.Top = MSFlexGrid1.CellTop + MSFlexGrid1.Top - 5
.Left = MSFlexGrid1.CellLeft + MSFlexGrid1.Left + 5
.Width = MSFlexGrid1.CellWidth
.Text = MSFlexGrid1.Text
.Visible = True
.ZOrder
.SetFocus
End With
End If
bool = False
End Sub
Private Sub tbrMain_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "New"
mnuFileNew_Click
Case "Save"
mnuFileSave_Click
Case "Open"
mnuFileOpen_Click
Case "Cut"
mnuEditcut_Click
Case "Copy"
mnuEditCopy_Click
Case "Paste"
mnuEditPaste_Click
Case "Delete"
mnuEditDelete_Click
Case "Undo"
Undo
Case "InsertRow"
mnuEditInsertRow_Click
Case "DelRow"
mnuEditDelRow_Click
End Select
End Sub
Private Sub txtEdit_LostFocus()
'Write the Contents of the Textbox into the Grid and hide the Textbox
If (m_ActiveCell.row <= KCount) And (Not bool) Then
MSFlexGrid1.TextMatrix(m_ActiveCell.row, m_ActiveCell.col) = txtEdit.Text
End If
txtEdit.Visible = False
MakeUndoBuffer "Input"
End Sub
Private Sub EmptyUndoBuffer()
ReDim m_UndoBuffer(0)
EnableUndo
End Sub
Private Sub Undo()
Dim lngRow As Long
Dim lngCol As Long
Dim lngTopRow As Long
With MSFlexGrid1
.Visible = False
lngRow = .row
lngCol = .col
lngTopRow = .TopRow
.Rows = m_UndoBuffer(UBound(m_UndoBuffer) - 1).uRows
.Cols = m_UndoBuffer(UBound(m_UndoBuffer) - 1).uCols
.row = 1
.col = 1
.RowSel = .Rows - 1
.ColSel = .Cols - 1
.Clip = m_UndoBuffer(UBound(m_UndoBuffer) - 1).uText
ReDim Preserve m_UndoBuffer(UBound(m_UndoBuffer) - 1)
On Error Resume Next
.row = lngRow
.col = lngCol
.TopRow = lngTopRow
.Visible = True
End With
EnableUndo
End Sub
Public Sub MakeUndoBuffer(Optional UndoName As String)
'You should call this Sub on every changes in the Grid
On Error GoTo DimBuff
Dim i As Long
Dim j As Long
Dim strClip As String
Dim tmpClip() As UndoType
With MSFlexGrid1
For i = 1 To .Rows - 1
For j = 1 To .Cols - 1
strClip = strClip & .TextMatrix(i, j) & vbTab
Next
strClip = strClip & vbCr
Next
'No Changes.
If strClip = m_UndoBuffer(UBound(m_UndoBuffer)).uText And _
m_UndoBuffer(UBound(m_UndoBuffer)).uRows = .Rows And _
m_UndoBuffer(UBound(m_UndoBuffer)).uCols = .Cols Then Exit Sub
'MaxUndo
If UBound(m_UndoBuffer) = (intMaxUndo - 1) Then
ReDim tmpClip(intMaxUndo - 1)
ReDim m_UndoBuffer(intMaxUndo - 1)
For i = 0 To intMaxUndo - 1
tmpClip(i).uCols = m_UndoBuffer(i).uCols
tmpClip(i).uRows = m_UndoBuffer(i).uRows
tmpClip(i).uText = m_UndoBuffer(i).uText
tmpClip(i).uName = m_UndoBuffer(i).uName
Next i
For i = 0 To intMaxUndo - 2
m_UndoBuffer(i).uCols = tmpClip(i + 1).uCols
m_UndoBuffer(i).uRows = tmpClip(i + 1).uRows
m_UndoBuffer(i).uText = tmpClip(i + 1).uText
tmpClip(i).uName = m_UndoBuffer(i).uName
Next i
Else
ReDim Preserve m_UndoBuffer(UBound(m_UndoBuffer) + 1)
End If
'Make Undobuffer
m_UndoBuffer(UBound(m_UndoBuffer)).uRows = .Rows
m_UndoBuffer(UBound(m_UndoBuffer)).uCols = .Cols
m_UndoBuffer(UBound(m_UndoBuffer)).uText = strClip
If Len(UndoName) Then
m_UndoBuffer(UBound(m_UndoBuffer)).uName = UndoName
Else
m_UndoBuffer(UBound(m_UndoBuffer)).uName = "Last Action"
End If
End With
EnableUndo
Exit Sub
DimBuff:
ReDim m_UndoBuffer(0)
Resume
End Sub
Private Sub EnableUndo()
'Enable Controls e.g. Menuitem (mnuEditUndo) and Toolbarbutton
mnuEditUndo.Enabled = (UBound(m_UndoBuffer) > 1)
tbrMain.Buttons("Undo").Enabled = (UBound(m_UndoBuffer) > 1)
If UBound(m_UndoBuffer) > 1 Then
tbrMain.Buttons("Undo").ToolTipText = "Undo: " & _
m_UndoBuffer(UBound(m_UndoBuffer)).uName & " (Ctrl+Z)"
mnuEditUndo.Caption = "Undo: " & _
m_UndoBuffer(UBound(m_UndoBuffer)).uName
Else
tbrMain.Buttons("Undo").ToolTipText = "Undo: Not possible (Ctrl+Z)"
mnuEditUndo.Caption = "Undo: Not possible"
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -