📄 ˮ
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "水准后处理程序"
ClientHeight = 4230
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 4230
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton 转换三等科傻格式
Caption = "转换三等科傻格式"
Height = 615
Left = 2520
TabIndex = 4
Top = 1680
Width = 1335
End
Begin VB.CommandButton 生成三等手簿
Caption = "生成三等手簿"
Height = 615
Left = 2520
TabIndex = 3
Top = 480
Width = 1335
End
Begin VB.CommandButton 关闭
Caption = "关闭"
Height = 615
Left = 1440
TabIndex = 2
Top = 3000
Width = 1335
End
Begin VB.CommandButton 转换手簿格式
Caption = "生成四等手簿"
Height = 615
Left = 480
TabIndex = 1
Top = 480
Width = 1335
End
Begin VB.CommandButton 转换科傻格式
Caption = "转换四等科傻格式"
Height = 615
Left = 480
TabIndex = 0
Top = 1680
Width = 1335
End
Begin VB.Line Line5
X1 = 2160
X2 = 2160
Y1 = 2520
Y2 = 360
End
Begin VB.Line Line4
X1 = 360
X2 = 360
Y1 = 2520
Y2 = 360
End
Begin VB.Line Line3
X1 = 3960
X2 = 3960
Y1 = 2520
Y2 = 360
End
Begin VB.Line Line2
X1 = 360
X2 = 3960
Y1 = 360
Y2 = 360
End
Begin VB.Line Line1
X1 = 3960
X2 = 360
Y1 = 2520
Y2 = 2520
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
Dim ki
Dim folderexist As String
Dim fso As New FileSystemObject
If fso.FolderExists("C:\Program Files\水准后处理程序") = True Then
folderexist = True
FileCopy "C:\Program Files\水准后处理程序\外业水准手簿.doc", "d:\外业水准手簿.doc"
Else
folderexist = False
ki = MsgBox("水准后处理程序安装时不允许更改目录！")
End
End If
End Sub
Private Sub 关闭_Click()
End
End Sub
Private Sub 生成三等手簿_Click()
Dim wd As Word.Application
Dim myrange1 As Object
Dim i, j, n, hs, zhs, zds, hang As Long
Dim k, k1, k2, temp As Double
Dim a2(2500), a3(2500), a4(2500), a5(2500), a6(2500), a7(2500), dist, jj100, a9(2500), a10(2500), a11(2500), a12(2500) As Double
Dim a1(2500), a8(2500), qsd, jsd, dh As String
Dim ki
On Error Resume Next
Open "d:\B42.txt" For Input As #1
If Err Then
ki = MsgBox("先把文件从掌上电脑复制到D:\的根目录下！")
Exit Sub
End If
i = 1
Do Until EOF(1)
Input #1, a1(i), a2(i), a3(i), a4(i), a5(i), a6(i), a7(i), a8(i), a9(i), a10(i), a11(i), a12(i)
i = i + 1
Loop
zhs = i - 1
Close #1
Set wd = New Word.Application
wd.Documents.Open "d:\外业水准手簿.doc"
wd.Visible = True
Set myrange1 = wd.ActiveDocument.Range
myrange1.Copy
biao = 1
n = 1
hs = 1
hang = 5
dist = 0
jj100 = 100
For i = 1 To zhs
If hs < 13 Then
If a1(i) = "0" And a6(i) <> "0" Then
k1 = a6(i): k2 = a7(i): qsd = a8(i)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=1).Range.InsertAfter "(" & qsd & ")" + Chr(13) + Chr(10)
ElseIf a1(i) = "1" Then
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=1).Range.InsertAfter CStr(n)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=2).Range.InsertAfter Format(a9(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=3).Range.InsertAfter Format(a10(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=1).Range.InsertAfter Format(a11(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=2).Range.InsertAfter Format(a12(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=1).Range.InsertAfter Format(a2(i), "#0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=5).Range.InsertAfter Format(a3(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=6).Range.InsertAfter Format(a4(i), "0000")
If (a3(i) + k2 - a4(i) > 10 Or a3(i) + k2 - a4(i) < -10) Then
temp = k1: k1 = k2: k2 = temp
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=7).Range.InsertAfter a3(i) + k2 - a4(i)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=2).Range.InsertAfter Format(a5(i), "#0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=4).Range.InsertAfter Format(a6(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=5).Range.InsertAfter Format(a7(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=6).Range.InsertAfter a6(i) + k1 - a7(i)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=4).Range.InsertAfter Format((a3(i) - a6(i)), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=5).Range.InsertAfter Format((a4(i) - a7(i)), "0000")
If (a3(i) - a6(i) - (a4(i) - a7(i) - jj100) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) - jj100) < -10) Then
jj100 = -jj100
Else
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=6).Range.InsertAfter a3(i) - a6(i) - (a4(i) - a7(i) - jj100)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=7).Range.InsertAfter Format(CStr((a3(i) - a6(i) + (a4(i) - a7(i) - jj100)) * 0.5), "0000.0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=1).Range.InsertAfter Format((a2(i) - a5(i)) / 10, "##0.0")
dist = dist + (a2(i) - a5(i)) / 10
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=2).Range.InsertAfter Format(dist, "#0.0")
temp = k1: k1 = k2: k2 = temp
jj100 = -jj100
hang = hang + 4
n = n + 1
hs = hs + 1
ElseIf a1(i) = "3" Then
dh = a8(i)
ElseIf a1(i) = "4" Then
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=1).Range.InsertAfter CStr(n) + Chr(13) + Chr(10)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=1).Range.InsertAfter "(" & dh & ")"
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=2).Range.InsertAfter Format(a9(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=3).Range.InsertAfter Format(a10(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=1).Range.InsertAfter Format(a11(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=2).Range.InsertAfter Format(a12(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=1).Range.InsertAfter Format(a2(i), "#0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=5).Range.InsertAfter Format(a3(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=6).Range.InsertAfter Format(a4(i), "0000")
If (a3(i) + k2 - a4(i) > 10 Or a3(i) + k2 - a4(i) < -10) Then
temp = k1: k1 = k2: k2 = temp
Else
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=7).Range.InsertAfter a3(i) + k2 - a4(i)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=2).Range.InsertAfter Format(a5(i), "#0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=4).Range.InsertAfter Format(a6(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=5).Range.InsertAfter Format(a7(i), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 1, Column:=6).Range.InsertAfter a6(i) + k1 - a7(i)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=4).Range.InsertAfter Format((a3(i) - a6(i)), "0000")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=5).Range.InsertAfter Format((a4(i) - a7(i)), "0000")
If (a3(i) - a6(i) - (a4(i) - a7(i) - jj100) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) - jj100) < -10) Then
jj100 = -jj100
Else
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=6).Range.InsertAfter a3(i) - a6(i) - (a4(i) - a7(i) - jj100)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=7).Range.InsertAfter Format(CStr((a3(i) - a6(i) + (a4(i) - a7(i) - jj100)) * 0.5), "0000.0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=1).Range.InsertAfter Format((a2(i) - a5(i)) / 10, "##0.0")
dist = dist + (a2(i) - a5(i)) / 10
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=2).Range.InsertAfter Format(dist, "#0.0")
temp = k1: k1 = k2: k2 = temp
jj100 = -jj100
hang = hang + 4
n = n + 1
hs = hs + 1
ElseIf (a1(i) = "0" And a6(i) = "0") Then
If hs - 1 Mod 12 <> 0 Then
If a1(i - 1) = 1 Then
wd.ActiveDocument.Tables(biao).Cell(Row:=hang - 4, Column:=1).Range.InsertAfter Chr(13) + Chr(10) + "(" & a8(i) & ")"
Else
End If
biao = biao + 1
hs = 1
hang = 5
n = 1
dist = 0
myrange1.SetRange Start:=wd.ActiveDocument.Range.End + 100, End:=wd.ActiveDocument.Range.End + 100
myrange1.Paste
Else
'wd.ActiveDocument.Tables(biao - 1).Cell(Row:=49, Column:=1).Range.InsertAfter Chr(13) + Chr(10) + "(" & a8(i) & ")"
hs = 1
hang = 5
n = 1
dist = 0
End If
Else
End If
Else
myrange1.SetRange Start:=wd.ActiveDocument.Range.End + 100, End:=wd.ActiveDocument.Range.End + 100
myrange1.Paste
biao = biao + 1
hs = 1
hang = 5
i = i - 1
End If
Next i
End Sub
Private Sub 转换科傻格式_Click()
Dim i, j, n, hs, zhs, zds, jsgd As Integer
Dim k, k1, k2, temp As Double
Dim yzd(100), gc(100), gaocha As Double
Dim a2(5000), a3(5000), a4(5000), a5(5000), a6(5000), a7(5000), dist, d(5000), g(5000), jj100 As Double
Dim a1(5000), a8(5000), kzddh(5000), jsdh(5000), qsd, jsd, dh As String
Dim ki
On Error Resume Next
Open "d:\b42.txt" For Input As #1
If Err Then
ki = MsgBox("先把b42文件从掌上电脑复制到D:\的根目录下！")
Exit Sub
End If
i = 1
Do Until EOF(1)
Input #1, a1(i), a2(i), a3(i), a4(i), a5(i), a6(i), a7(i), a8(i)
i = i + 1
Loop
zhs = i - 1
Close #1
Open "d:\knownheightpoint.txt" For Input As #2
If Err Then
ki = MsgBox("先把knownheightpoint文件从掌上电脑复制到D:\的根目录下！")
Exit Sub
Else
End If
i = 1
Do Until EOF(2)
Input #2, yzd(i), gc(i)
i = i + 1
Loop
zds = i - 1
Close #2
Open "d:\科傻IN1水准格式.in1" For Output As #3
For i = 1 To zds
Print #3, yzd(i) & "," & Format(gc(i), "#0.000")
Next i
k = 1
dist = 0
gaocha = 0
hs = 1
For i = 1 To zhs
If a1(i) = "0" And a6(i) <> "0" Then
k1 = a6(i): k2 = a7(i)
kzddh(hs) = a8(i)
ElseIf a1(i) = "1" Then
dist = dist + a2(i) + a5(i)
If (a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) < -10) Then
temp = k1: k1 = k2: k2 = temp
Else
End If
gaocha = gaocha + (a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5
jsgd = i
ElseIf a1(i) = "3" Then
k = k + 1
hs = hs + 1
kzddh(hs) = a8(i)
ElseIf a1(i) = "4" Then
d(k) = dist + a2(i) + a5(i)
If (a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) < -10) Then
temp = k1: k1 = k2: k2 = temp
Else
End If
g(k) = gaocha + (a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -