ˮ׼

可以通过此程序转换成水准手簿及平差文件格式

dist = 0
gaocha = 0
Print #3, kzddh(hs - 1) & "," & kzddh(hs) & "," & Format(g(k) / 1000, "####0.0000") & "," & Format(d(k) / 1000, "####0.0000")
jsgd = i

ElseIf a1(i) = "2" Then
k = k + 1
jsdh(k) = a8(i)
d(k) = dist + a2(i) + 100
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
 'If (a2(i) = a2(jsgd) And a3(i) = a3(jsgd) And a4(i) = a4(jsgd)) Then
 d(k) = dist + a2(i) + 100 ' - (a2(jsgd) + a5(jsgd))
 g(k) = gaocha + (a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5 '- (a3(jsgd) - a6(jsgd) + (a4(jsgd) - a7(jsgd) + k1 - k2)) * 0.5
Print #3, kzddh(hs) & "," & jsdh(k) & "," & Format(g(k) / 1000, "####0.0000") & "," & Format(d(k) / 1000, "####0.0000")
' Else
 'End If
 
 
 
 
ElseIf a1(i) = "0" And a6(i) = "0" Then
  If a1(i - 1) = 1 Then
  k = k + 1
  hs = hs + 1
kzddh(hs) = a8(i)
d(k) = dist
  g(k) = gaocha
  Print #3, kzddh(hs - 1) & "," & kzddh(hs) & "," & Format(g(k) / 1000, "####0.0000") & "," & Format(d(k) / 1000, "####0.0000")
  dist = 0
  gaocha = 0
  Else
  k = 1: hs = 1: dist = 0: gaocha = 0
  End If
Else
End If
Next i
Close #3

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(500), a3(500), a4(500), a5(500), a6(500), a7(500), dist, d(500), g(500), jj100, a9(500), a10(500), a11(500), a12(500) As Double
Dim a1(500), a8(500), kzddh(500), jsdh(500), 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), a9(i), a10(i), a11(i), a12(i)
a2(i) = a2(i) / 10
a5(i) = a5(i) / 10
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
dist = 0
gaocha = 0
Print #3, kzddh(hs - 1) & "," & kzddh(hs) & "," & Format(g(k) / 1000, "####0.0000") & "," & Format(d(k) / 1000, "####0.0000")
jsgd = i

'ElseIf a1(i) = "2" Then
'k = k + 1
'jsdh(k) = a8(i)
'd(k) = dist + a2(i) + 100
'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
 ''If (a2(i) = a2(jsgd) And a3(i) = a3(jsgd) And a4(i) = a4(jsgd)) Then
 'd(k) = dist + a2(i) + 100 ' - (a2(jsgd) + a5(jsgd))
 'g(k) = gaocha + (a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5 '- (a3(jsgd) - a6(jsgd) + (a4(jsgd) - a7(jsgd) + k1 - k2)) * 0.5
'Print #3, kzddh(hs) & "," & jsdh(k) & "," & Format(g(k) / 1000, "####0.0000") & "," & Format(d(k) / 1000, "####0.0000")
' Else
 'End If
 
ElseIf a1(i) = "0" And a6(i) = "0" Then
  If a1(i - 1) = 1 Then
  k = k + 1
  hs = hs + 1
kzddh(hs) = a8(i)
d(k) = dist
  g(k) = gaocha
  Print #3, kzddh(hs - 1) & "," & kzddh(hs) & "," & Format(g(k) / 1000, "####0.0000") & "," & Format(d(k) / 1000, "####0.0000")
  dist = 0
  gaocha = 0
  Else
  k = 1: hs = 1: dist = 0: gaocha = 0
  End If
Else
End If
Next i
Close #3


End Sub

Private Sub 转换手簿格式_Click()
Dim wd As Word.Application
Dim myrange1 As Object
Dim i, j, n, hs, zhs, zds, hang As Integer
Dim k, k1, k2, temp As Double
Dim a2(5000), a3(5000), a4(5000), a5(5000), a6(5000), a7(5000), dist, jj100 As Double
Dim a1(5000), a8(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("先把文件从掌上电脑复制到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

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


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 + 2, Column:=1).Range.InsertAfter Format(a2(i), "#0.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.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) + k1 - k2) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) < -10) Then
jj100 = 100
Else
jj100 = 0
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=6).Range.InsertAfter a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2 - jj100)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=7).Range.InsertAfter Format(CStr((a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2 - jj100)) * 0.5), "0000.0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=1).Range.InsertAfter Format((a2(i) - a5(i)), "##0.0")
dist = dist + (a2(i) - a5(i))
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=2).Range.InsertAfter Format(dist, "#0.0")
temp = k1: k1 = k2: k2 = temp
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 + 2, Column:=1).Range.InsertAfter Format(a2(i), "#0.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.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) + k1 - k2) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) < -10) Then
jj100 = 100
Else
jj100 = 0
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=6).Range.InsertAfter a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2 - jj100)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=7).Range.InsertAfter Format(CStr((a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5), "0000.0")
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=1).Range.InsertAfter Format((a2(i) - a5(i)), "##0.0")
dist = dist + (a2(i) - a5(i))
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 3, Column:=2).Range.InsertAfter Format(dist, "#0.0")
temp = k1: k1 = k2: k2 = temp
hang = hang + 4
n = n + 1
hs = hs + 1
ElseIf a1(i) = "2" Then
k = a5(i)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=1).Range.InsertAfter a8(i)
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
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=7).Range.InsertAfter a3(i) + k1 - a4(i)
Else
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=7).Range.InsertAfter a3(i) + k2 - a4(i)
End If
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) + k - 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) + k1 - k2) > 10 Or a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2) < -10) Then
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=6).Range.InsertAfter a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=7).Range.InsertAfter Format(CStr((a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5), "0000.0")
Else
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=6).Range.InsertAfter a3(i) - a6(i) - (a4(i) - a7(i) + k1 - k2)
wd.ActiveDocument.Tables(biao).Cell(Row:=hang + 2, Column:=7).Range.InsertAfter Format(CStr((a3(i) - a6(i) + (a4(i) - a7(i) + k1 - k2)) * 0.5), "0000.0")
End If
wd.ActiveDocument.Tables(biao).Cell(Row:=hang, Column:=9).Range.InsertAfter "间视"
hang = hang + 4
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:=33, 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