n120.bas

一个勘察用的小软件,和华宁配套用. 一个勘察用的小软件,和华宁配套用.

Attribute VB_Name = "Module2"
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Public Const MAX_PATH = 260
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

Dim m As Integer, lx, ly, ti

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
      dwFileAttributes As Long
      ftCreationTime As FILETIME
      ftLastAccessTime As FILETIME
      ftLastWriteTime As FILETIME
      nFileSizeHigh As Long
      nFileSizeLow As Long
      dwReserved0 As Long
      dwReserved1 As Long
      cFileName As String * MAX_PATH
      cAlternate As String * 14
End Type
Function hnbh(dirs As Variant) As String  '取得华宁编号
Dim lpFileName As String, lpFindFileData As WIN32_FIND_DATA, fd As Variant, wjm As String, zf As String, dmlen As Integer
Dim hndm As String
ti = 0
    lpFileName = dirs + "\GCMC.*"
    fd = FindFirstFile(lpFileName, lpFindFileData)
    wjm = lpFindFileData.cFileName
    FindClose (fd)
    '取得后缀
    dmlen = Len(wjm)
    wjm = Left(wjm, 7)
    hndm = Right(wjm, Len(wjm) - 4)
    hnbh = hndm
    CloseHandle (fd)
End Function
Function dcsj(hnbh As String) As String '取得dcsj文档
dcsj = "DCSJ" + hnbh
End Function
Function zk120(hnbh As String, zkh As String) As String '取得N120文档
zk120 = "N12" + zkh + hnbh
End Function
Function dk120(dirs As Variant, dcsj文件 As String, Grid As Object, zkh As String)    '取得单孔分层信息
Dim dkdir, dh, dk, zm, kh, i, n, nn, rowk, colk, fcbh, sd
kh = ""
dk = ""
m = 0
rowk = 1
colk = 2
fgh = 0
fg = 0
dkdir = dirs + "\" + dcsj文件
'——————————————————初始化表格——————————————
For i = 1 To 19
    Grid.TextMatrix(i, 1) = ""
    Grid.TextMatrix(i, 2) = ""
Next i
'——————————————————初始化表格——————————————
filenum = FreeFile


On Error Resume Next
Open dkdir For Input As #filenum
If Err Then
dk120 = 0
Exit Function
End If
Do While Not EOF(1)
Line Input #filenum, dh


For i = 1 To Len(dh)  '取得钻孔号
zm = Left(dh, 1)
dh = Right(dh, Len(dh) - 1)
If zm = "E" Then
Exit Do
End If
If zm = "," Then
Exit For
End If
If zm >= 0 And zm <= 9 Then
sd = sd + zm
kh = sd
End If
If kh = zkh Then
fg = 1
End If
If kh <> zkh And fg = 1 Then
Exit Do
End If
Next i

If kh = zkh Then       '取得钻孔分层信息
nn = n
m = m + 1
For i = 1 To Len(dh)
zm = Left(dh, 1)
dh = Right(dh, Len(dh) - 1)

If zm = "," Then
Select Case colk
Case 2
colk = 1
Case 1
colk = 2
End Select
fcbh = dk
Grid.TextMatrix(rowk, colk) = fcbh
dk = ""
End If

If zm <> "," Then
dk = dk + zm
End If

If Len(dh) < 1 Then
rowk = rowk + 1
sd = ""
End If
Next i

End If

If kh <> zkh Then
sd = ""
End If
If kh <> zkh And n > 1 And zm <> "," Then
Exit Do
End If
n = n + 1

Loop
Close #filenum
dk120 = 1
End Function
Function n120gb(dirs As String, wj As String, xzxs As Variant, zd As Variant)     'n120击数修正
Dim n120File As String, n120Line As String, n120L As String, n120Ll As String, n120js As Variant, zm, n As Integer
Dim 修正系数1  As Double, 修正系数2  As Double, 修正系数 As Double, xzxsz As Variant, rows As Integer, cols As Integer
Dim 修正击数 As Double, qd, j
Set xzxsz = xzxs.ActiveSheet
n = 0
X = 1
endf = 1
n120File = dirs + "\" + wj
j = 0
n120 = 0
filenum = FreeFile
h = 100

On Error Resume Next
Open n120File For Input As #filenum
If Err Then
Exit Function
End If
Do While Not EOF(1)
Line Input #filenum, n120Line
n = n + 1
If n120Line <> " 0 , 0 " Then
endf = 0
j = j + 1
zd = n
'————————取得杆长————————————
If X = 1 Then
X = 2
qd = n
End If
Do While zm <> ","
zm = Left(n120Line, 1)
n120Line = Right(n120Line, Len(n120Line) - 1)
If zm >= 0 And zm <= 9 Or zm = "." Then
n120Ll = n120Ll + zm
If n120Ll > 0 Then
n120L = n120Ll
End If
End If
Loop
'————————取得杆长————————————
n120Line = Right(n120Line, Len(n120Line) - 1)
'————————取得实测击数————————————
Do While n120Line <> ""
zm = Left(n120Line, 1)
n120Line = Right(n120Line, Len(n120Line) - 1)
If zm >= 0 And zm <= 9 Or zm = "." Then
n120js = n120js + zm
End If
Loop
'————————取得实测击数————————————

'————————取得修正击数————————————

If n120js <> "" Then
If Int(n120js) <= 20 Then
cols = Int(n120js) + 1
Else
cols = 21
End If
For rows = 2 To 12
If CDbl(n120L) >= xzxsz.Cells(rows, 1) And CDbl(n120L) <= xzxsz.Cells(rows + 1, 1) Then
修正系数1 = xzxsz.Cells(rows, cols)
修正系数2 = xzxsz.Cells(rows + 1, cols)
修正系数 = 修正系数1 - (修正系数1 - 修正系数2) * (n120L - xzxsz.Cells(rows, 1)) / (xzxsz.Cells(rows + 1, 1) - xzxsz.Cells(rows, 1))
Exit For
ElseIf n120L > 20 Then
修正系数 = xzxsz.Cells(12, cols)
Exit For
End If
Next rows
修正击数 = n120js * 修正系数
n120gb = qd
xzxsz.Cells(h, 1) = 修正击数
h = h + 1
End If
'————————取得修正击数————————————

End If
n120Ll = ""
n120js = ""
If endf = 0 And n120Line = " 0 , 0 " Then
Exit Do
End If
Loop
zd = j
Close #filenum
End Function


Function n120cd(dirs As String, wj As String, xzxs As Variant, zd As Variant)     'n120击数修正
Dim n120File As String, n120Line As String, n120L As String, n120Ll As String, n120js As Variant, zm, n As Integer
Dim 修正系数1  As Double, 修正系数2  As Double, 修正系数 As Double, xzxsz As Variant, rows As Integer, cols As Integer
Dim 修正击数 As Double, qd, j
Set xzxsz = xzxs.ActiveSheet
n = 0
X = 1
endf = 1
n120File = dirs + "\" + wj
j = 0
n120 = 0
filenum = FreeFile
h = 100

On Error Resume Next
Open n120File For Input As #filenum
If Err Then
Exit Function
End If
Do While Not EOF(1)
Line Input #filenum, n120Line
n = n + 1
If n120Line <> " 0 , 0 " Then
endf = 0
j = j + 1
zd = n
'————————取得杆长————————————
If X = 1 Then
X = 2
qd = n
End If
Do While zm <> ","
zm = Left(n120Line, 1)
n120Line = Right(n120Line, Len(n120Line) - 1)
If zm >= 0 And zm <= 9 Or zm = "." Then
n120Ll = n120Ll + zm
If n120Ll > 0 Then
n120L = n120Ll
End If
End If
Loop
'————————取得杆长————————————
n120Line = Right(n120Line, Len(n120Line) - 1)
'————————取得实测击数————————————
Do While n120Line <> ""
zm = Left(n120Line, 1)
n120Line = Right(n120Line, Len(n120Line) - 1)
If zm >= 0 And zm <= 9 Or zm = "." Then
n120js = n120js + zm
End If
Loop
'————————取得实测击数————————————

'————————取得修正击数————————————

If n120js <> "" Then
If Int(n120js) <= 2 Then
cols = 1
ElseIf Int(n120js) <= 20 Then
cols = Int(n120js) - 1
ElseIf Int(n120js) > 20 Then
cols = 20
End If
For rows = 51 To 60
fg = xzxsz.Cells(rows, 1)
fk = xzxsz.Cells(rows + 1, 1)
If CDbl(n120L) >= xzxsz.Cells(rows, 1) And CDbl(n120L) <= xzxsz.Cells(rows + 1, 1) Then
修正系数1 = xzxsz.Cells(rows, cols)
修正系数2 = xzxsz.Cells(rows + 1, cols)
修正系数 = 修正系数1 - (修正系数1 - 修正系数2) * (n120L - xzxsz.Cells(rows, 1)) / (xzxsz.Cells(rows + 1, 1) - xzxsz.Cells(rows, 1))
Exit For
ElseIf n120L > 20 Then
修正系数 = xzxsz.Cells(60, cols)
Exit For
End If
Next rows
修正击数 = n120js * 修正系数
n120cd = qd
xzxsz.Cells(h, 1) = 修正击数
h = h + 1
End If
'————————取得修正击数————————————

End If
n120Ll = ""
n120js = ""
If endf = 0 And n120Line = " 0 , 0 " Then
Exit Do
End If
Loop
zd = j
Close #filenum
End Function


Function 保存数据(dcsj As String, dirs As String, Grid As Object, kh As String)
Dim shead As String, send As String, sdk As String, n, nn
Dim dcsjFILE As String
Dim rowk
sdk = ""
rowk = 1
n = 0
nn = 0
dcsjFILE = dirs + "\" + dcsj
'————————————————孔号部分——————————
Do While Grid.TextMatrix(rowk, 1) <> ""
    If rowk = 1 Then
    sdk = kh + "," + Grid.TextMatrix(rowk, 1) + "," + Grid.TextMatrix(rowk, 2) + "," & Chr(13) & Chr(10)
    Else
    sdk = sdk + "," + Grid.TextMatrix(rowk, 1) + "," + Grid.TextMatrix(rowk, 2) + "," & Chr(13) & Chr(10)
End If
rowk = rowk + 1
Loop
'————————————————孔号部分——————————
filenum = FreeFile

On Error Resume Next
Open dcsjFILE For Input As #filenum
If Err Then
GoTo l
End If
Do While Not EOF(1)
'————————————————第一部分——————————
Line Input #filenum, sheads
sheadss = sheads
For i = 1 To Len(sheads)
zkh1 = Left(sheads, 1)
sheads = Right(sheads, Len(sheads) - 1)
If zkh1 = "," Then
Exit For
End If
zkh2 = zkh2 + zkh1
Next i
If zkh2 = kh Then
Exit Do
End If
zkh2 = ""
shead = shead + sheadss & Chr(13) & Chr(10)
n = n + 1
Loop
'————————————————第一部分——————————


'————————————————第二部分——————————
nn = n - nn + 1
j = m
Do While Not EOF(1)
Line Input #1, sends
If nn >= m + n Then
send = send + sends & Chr(13) & Chr(10)
End If
If sends = "" Then
l:
send = "END,END,END,END" & Chr(13) & Chr(10)
Exit Do
End If
nn = nn + 1
Loop
Close #filenum
'————————————————第二部分——————————

filenum = FreeFile

Open dcsjFILE For Output As #filenum
保存数据 = shead + sdk + send
Print #filenum, 保存数据
Close #filenum

End Function
Function 绘图(sheet As Variant, p As Variant)
Dim n120sheet, i, js, n
Set n120sheet = sheet.ActiveSheet
i = 100
n = 2
k1 = n120sheet.Cells(100, 1)
js = n120sheet.Cells(100, 1) * 200
p.Line (500 + js, -1000)-(500 + js, -1000 - 100), QBColor(12)
i = i + 1
k = n120sheet.Cells(i, 1)
Do While n120sheet.Cells(i, 1) <> ""
js = n120sheet.Cells(i, 1) * 200
k2 = n120sheet.Cells(i, 1)
X1 = 500 + js
p.Line (500 + js, -1000 - (n - 1) * 100)-(500 + n120sheet.Cells(i - 1, 1) * 200, -1000 - (n - 1) * 100), QBColor(12)
p.Line (500 + js, -1000 - (n - 1) * 100)-(500 + js, -1000 - n * 100), QBColor(12)
i = i + 1
n = n + 1
Loop
End Function