📄 中桩大地坐标.frm
字号:
Text17.Text = Str(Int(q1 * 1000 + 0.5) / 1000)
Text21.Text = Str(Int(q2 * 1000 + 0.5) / 1000)
jz = zh
'加桩计算
num = 1
Do
Call jzjsu
Call zbzh '坐标转换为大地坐标
For i = 1 To VSFlexGrid1.Rows - 1
If VSFlexGrid1.TextMatrix(i, 1) = "" Then Exit For
Next i
VSFlexGrid1.TextMatrix(i, 0) = i
VSFlexGrid1.TextMatrix(i, 1) = Int(jz * 1000 + 0.5) / 1000
VSFlexGrid1.TextMatrix(i, 2) = Int(x * 1000 + 0.5) / 1000
VSFlexGrid1.TextMatrix(i, 3) = Int(y * 1000 + 0.5) / 1000
VSFlexGrid1.TextMatrix(i, 4) = Trim$(Str(ia)) + Trim$("°") + Trim$(Str(ib)) + Trim$("′") + Trim$(Str(Int(ic * 10) / 10)) + Trim$("″")
VSFlexGrid1.TextMatrix(i, 8) = Int(xm * 1000 + 0.5) / 1000 '中桩大地坐标
VSFlexGrid1.TextMatrix(i, 9) = Int(ym * 1000 + 0.5) / 1000
' VSFlexGrid1.TextMatrix(i, 8) = Int(x1 * 1000 + 0.5) / 1000 '中桩统一坐标
' VSFlexGrid1.TextMatrix(i, 9) = Int(y1 * 1000 + 0.5) / 1000
xb = x11
yb = y11
Call bzjs
If Option1.Value = True Then
xbz1 = xbm
ybz1 = ybm
End If
If Option2.Value = True Then
xbz1 = xbm
ybz1 = ybm
End If
xb = x12
yb = y12
Call bzjs
If Option1.Value = True Then
xbz2 = xbm
ybz2 = ybm
End If
If Option2.Value = True Then
xbz2 = xbm
ybz2 = ybm
End If
x1 = xbz1
y1 = ybz1
If Option1.Value = True Then y1 = -y1
Call zbzh
VSFlexGrid1.TextMatrix(i, 5) = Text10.Text
VSFlexGrid1.TextMatrix(i, 6) = Int(xm * 1000 + 0.5) / 1000 '左侧边桩大地坐标
VSFlexGrid1.TextMatrix(i, 7) = Int(ym * 1000 + 0.5) / 1000
' VSFlexGrid1.TextMatrix(i, 6) = Int(x1 * 1000 + 0.5) / 1000 '边桩统一坐标
' VSFlexGrid1.TextMatrix(i, 7) = Int(y1 * 1000 + 0.5) / 1000
x1 = xbz2
y1 = ybz2
If Option1.Value = True Then y1 = -y1
Call zbzh
VSFlexGrid1.TextMatrix(i, 10) = Text11.Text
VSFlexGrid1.TextMatrix(i, 11) = Int(xm * 1000 + 0.5) / 1000 '右侧边桩大地坐标
VSFlexGrid1.TextMatrix(i, 12) = Int(ym * 1000 + 0.5) / 1000
' VSFlexGrid1.TextMatrix(i, 11) = Int(x1 * 1000 + 0.5) / 1000 '边桩统一坐标
' VSFlexGrid1.TextMatrix(i, 12) = Int(y1 * 1000 + 0.5) / 1000
If jz = zh Or jz = hy Or jz = qz Or jz = yh Or jz = hz Then
VSFlexGrid1.Cell(flexcpBackColor, i, 1, i, 12) = &HFFFFC0
End If
VSFlexGrid1.Rows = VSFlexGrid1.Rows + 1
jz = Int(jz / LJ) * LJ + LJ
If jz - LJ < qz And qz < jz + LJ And num = 1 And ls1 = 0 Then jz = qz: num = num + 1
If jz - LJ < yh And yh < jz + LJ And num = 2 And ls1 = 0 Then jz = yh: num = num + 1
If jz - LJ < hy And hy < jz + LJ And num = 1 And ls1 <> 0 Then jz = hy: num = num + 1
If jz - LJ < qz And qz < jz + LJ And num = 2 Then jz = qz: num = num + 1
If jz - LJ < yh And yh < jz + LJ And num = 3 Then jz = yh: num = num + 1
If jz - LJ < hz And hz < jz + LJ And num = 4 Then jz = hz: num = num + 1
Loop While jz <= hz
Command4.Enabled = True
Text9.Text = ""
Text9.SetFocus
Exit Sub
handlerror:
xianshi = MsgBox("在计算曲线要素时出错。", vbInformation, "问题提示")
End Sub
Private Sub Command2_Click()
'保存
If rjsfzc = 88 Then
If FileName = "" Then
CommonDialog1.CancelError = True
On Error GoTo Erra
CommonDialog1.Filter = "text files(*.txt)|*.txt|all files(*.*)|*.*"
CommonDialog1.ShowSave
FileName = CommonDialog1.FileName
End If
Open FileName For Append As #1
wjtxt = ""
For i = 0 To VSFlexGrid1.Rows - 2
If wjtxt <> "" Then wjtxt = wjtxt & vbCrLf & VSFlexGrid1.TextMatrix(i, 0) + " " + VSFlexGrid1.TextMatrix(i, 1) + " " + VSFlexGrid1.TextMatrix(i, 2) + " " + VSFlexGrid1.TextMatrix(i, 3) + " " + VSFlexGrid1.TextMatrix(i, 4) + " " + VSFlexGrid1.TextMatrix(i, 5) + " " + VSFlexGrid1.TextMatrix(i, 6) + " " + VSFlexGrid1.TextMatrix(i, 7) + " " + VSFlexGrid1.TextMatrix(i, 8) + " " + VSFlexGrid1.TextMatrix(i, 9) + " " + VSFlexGrid1.TextMatrix(i, 10)
If wjtxt = "" Then wjtxt = VSFlexGrid1.TextMatrix(i, 0) + " " + VSFlexGrid1.TextMatrix(i, 1) + " " + VSFlexGrid1.TextMatrix(i, 2) + " " + VSFlexGrid1.TextMatrix(i, 3) + " " + VSFlexGrid1.TextMatrix(i, 4) + " " + VSFlexGrid1.TextMatrix(i, 5) + " " + VSFlexGrid1.TextMatrix(i, 6) + " " + VSFlexGrid1.TextMatrix(i, 7) + " " + VSFlexGrid1.TextMatrix(i, 8) + " " + VSFlexGrid1.TextMatrix(i, 9) + " " + VSFlexGrid1.TextMatrix(i, 10)
Next i
Print #1, wjtxt
Close #1
End If
Exit Sub
Erra:
xianshi = MsgBox("在保存文件时出错。", vbInformation, "问题提示")
End Sub
Private Sub Command3_Click()
'清空
On Error GoTo handlerror
xianshi = MsgBox("确实要清空所有数据文件吗？", vbYesNo, "问题提示")
If xianshi = 6 Then
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
Text8.Text = ""
Text9.Text = ""
Text10.Text = ""
Text11.Text = ""
Text12.Text = ""
Text13.Text = ""
Text14.Text = ""
Text15.Text = ""
Text16.Text = ""
Text17.Text = ""
Text18.Text = ""
Text19.Text = ""
Text20.Text = ""
Text21.Text = ""
Text22.Text = Trim$(Str(10))
For i = 1 To VSFlexGrid1.Rows - 1
VSFlexGrid1.TextMatrix(i, 0) = ""
VSFlexGrid1.TextMatrix(i, 1) = ""
VSFlexGrid1.TextMatrix(i, 2) = ""
VSFlexGrid1.TextMatrix(i, 3) = ""
VSFlexGrid1.TextMatrix(i, 4) = ""
VSFlexGrid1.TextMatrix(i, 5) = ""
VSFlexGrid1.TextMatrix(i, 6) = ""
VSFlexGrid1.TextMatrix(i, 7) = ""
VSFlexGrid1.TextMatrix(i, 8) = ""
VSFlexGrid1.TextMatrix(i, 9) = ""
VSFlexGrid1.TextMatrix(i, 10) = ""
VSFlexGrid1.TextMatrix(i, 11) = ""
VSFlexGrid1.TextMatrix(i, 12) = ""
Next i
VSFlexGrid1.Rows = 2
Text1.SetFocus
End If
Command4.Enabled = False
Exit Sub
handlerror:
xianshi = MsgBox("在清空所有数据文件时出错", vbInformation, "问题提示")
End Sub
Private Sub Command4_Click()
'加桩计算
On Error GoTo handlerror
d1 = Val(Text10.Text)
d2 = Val(Text11.Text)
jz = Val(Text9.Text)
Call jzjsu
Call zbzh
For i = 1 To VSFlexGrid1.Rows - 1
If VSFlexGrid1.TextMatrix(i, 1) = "" Then Exit For
Next i
VSFlexGrid1.TextMatrix(i, 0) = i
VSFlexGrid1.TextMatrix(i, 1) = Int(jz * 1000 + 0.5) / 1000
VSFlexGrid1.TextMatrix(i, 2) = Int(x * 1000 + 0.5) / 1000
VSFlexGrid1.TextMatrix(i, 3) = Int(y * 1000 + 0.5) / 1000
VSFlexGrid1.TextMatrix(i, 4) = Str(ia) + "°" + Trim$(Str(ib)) + "′" + Trim$(Str(Int(ic * 10) / 10)) + "″"
VSFlexGrid1.TextMatrix(i, 8) = Int(xm * 1000 + 0.5) / 1000 '中桩大地坐标
VSFlexGrid1.TextMatrix(i, 9) = Int(ym * 1000 + 0.5) / 1000
' VSFlexGrid1.TextMatrix(i, 8) = Int(x1 * 1000 + 0.5) / 1000 '中桩统一坐标
' VSFlexGrid1.TextMatrix(i, 9) = Int(y1 * 1000 + 0.5) / 1000
xb = x11
yb = y11
Call bzjs
If Option1.Value = True Then
xbz1 = xbm
ybz1 = ybm
End If
If Option2.Value = True Then
xbz1 = xbm
ybz1 = ybm
End If
xb = x12
yb = y12
Call bzjs
If Option1.Value = True Then
xbz2 = xbm
ybz2 = ybm
End If
If Option2.Value = True Then
xbz2 = xbm
ybz2 = ybm
End If
x1 = xbz1
y1 = ybz1
If Option1.Value = True Then y1 = -y1
Call zbzh
VSFlexGrid1.TextMatrix(i, 5) = Text10.Text
VSFlexGrid1.TextMatrix(i, 6) = Int(xm * 1000 + 0.5) / 1000 '左侧边桩大地坐标
VSFlexGrid1.TextMatrix(i, 7) = Int(ym * 1000 + 0.5) / 1000
' VSFlexGrid1.TextMatrix(i, 6) = Int(x1 * 1000 + 0.5) / 1000 '边桩统一坐标
' VSFlexGrid1.TextMatrix(i, 7) = Int(y1 * 1000 + 0.5) / 1000
x1 = xbz2
y1 = ybz2
If Option1.Value = True Then y1 = -y1
Call zbzh
VSFlexGrid1.TextMatrix(i, 10) = Text11.Text
VSFlexGrid1.TextMatrix(i, 11) = Int(xm * 1000 + 0.5) / 1000 '右侧边桩大地坐标
VSFlexGrid1.TextMatrix(i, 12) = Int(ym * 1000 + 0.5) / 1000
' VSFlexGrid1.TextMatrix(i, 11) = Int(x1 * 1000 + 0.5) / 1000 '边桩统一坐标
' VSFlexGrid1.TextMatrix(i, 12) = Int(y1 * 1000 + 0.5) / 1000
VSFlexGrid1.Rows = VSFlexGrid1.Rows + 1
Text9.Text = ""
Text9.SetFocus
Exit Sub
handlerror:
xianshi = MsgBox("在计算加桩时出错", vbInformation, "问题提示")
End Sub
Private Sub Command5_Click()
'到EXCEL
Dim xlApp As Excel.Application
On Error GoTo handlerror
If rjsfzc = 88 Then
Set xlApp = New Excel.Application
Set xlApp = CreateObject("Excel.Application")
'激活EXCEL应用程序
xlApp.Visible = True '隐藏EXCEL应用程序窗口
Set xlBook = xlApp.Workbooks.Add
'打开工作簿，strDestination为一个EXCEL报表文件
Set xlsheet = xlBook.Worksheets(1)
xlsheet.Range("A1:M1").MergeCells = True
For i = 0 To VSFlexGrid1.Rows - 2
For j = 0 To VSFlexGrid1.Cols - 1
xlsheet.Cells(i + 3, j + 1) = VSFlexGrid1.TextMatrix(i, j)
Next j
Next i
xlsheet.PageSetup.Orientation = xlLandscape
xlsheet.PageSetup.PaperSize = xlPaperA4
xlsheet.PageSetup.PrintTitleRows = "$1:$3"
With xlsheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.590551181102362)
.TopMargin = Application.InchesToPoints(0.78740157480315)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.CenterHorizontally = True
' .CenterVertically = True
End With
xlsheet.Cells(1, 1) = "中 桩 大 地 坐 标"
xlsheet.Rows(3).WrapText = True
xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(i + 2, j)).Borders.LineStyle = xlContinuous
xlsheet.Range(xlsheet.Cells(3, 1), xlsheet.Cells(i + 2, j)).Borders.Weight = xlThin
xlsheet.Range("A1:M1").MergeCells = True
xlsheet.Columns("A:M").AutoFit
xlsheet.Range("A1:M1").HorizontalAlignment = xlCenter
xlsheet.Range("A1:M1").VerticalAlignment = xlCenter
xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 13)).Font.Name = "宋体"
xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 13)).Font.Bold = True
xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, 13)).Font.Size = 20
xlsheet.Range(xlsheet.Cells(2, 1), xlsheet.Cells(i + 4, 13)).Font.Size = 10
End If
Exit Sub
handlerror:
xianshi = MsgBox("在打印到EXCEL出错", vbInformation, "问题提示")
End Sub
Private Sub Command6_Click()
'关闭
On Error GoTo handlerror
If rjsfzc = 88 And VSFlexGrid1.Rows > 2 Then
frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 十五、中桩大地坐标计算结果："
frmMain.Text1 = frmMain.Text1 & vbCrLf & " ～～～～～～～曲线要素～～～～～～～"
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 路线交点 （m）JD＝ " + Str(jd)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 路线偏角（°′″）PJ＝ " + Str(alp)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 圆曲线半径 （m）R ＝ " + Str(Int(r * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 缓和曲线长度 （m）Ls1＝ " + Str(Int(ls1 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 缓和曲线长度 （m）Ls2＝ " + Str(Int(ls2 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 切线长度 （m）Th1＝ " + Str(Int(th1 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 切线长度 （m）Th2＝ " + Str(Int(th2 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 中间圆曲线长 （m）Ly＝ " + Str(Int(ly * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 平曲线全长 （m）Lh＝ " + Str(Int(lh * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 系数 （m）P1＝ " + Str(Int(p1 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 系数 （m）P2＝ " + Str(Int(p2 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 系数 （m）Q1＝ " + Str(Int(q1 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 系数 （m）Q2＝ " + Str(Int(q2 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 左侧距离 （m）Lz＝ " + Str(Int(d1 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " 右侧距离 （m）Yz＝ " + Str(Int(d2 * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
frmMain.Text1 = frmMain.Text1 & vbCrLf & " －－－－－－控制点桩号－－－－－－"
frmMain.Text1 = frmMain.Text1 & vbCrLf & " ZH= " + Str(Int(zh * 1000 + 0.5) / 1000)
frmMain.Text1 = frmMain.Text1 & vbCrLf & " HY= " + Str(Int(hy * 1000 + 0.5) / 1000)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -