Dim fs, f, f1, fc, s, Work_Book, ASheets, qxSheet, data_path
Type Bin_Single
b1 As Byte
b2 As Byte
b3 As Byte
b4 As Byte
End Type
'对文件夹中测井曲线进行转换主程序
'本程序主要逐一提取文件名，并调用cjqxgy过程进行转换
Sub 测井曲线整理()
Set Work_Book = Workbooks("测井曲线标准化.xls")
Set ASheets = Work_Book.Sheets("jh")
data_path = "C:\测井数据（原始）"
data_outpath = "C:\测井数据（整理）"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(data_path)
Set fc = f.Files
For Each f1 In fc
s = f1.Name
If Left(s, 1) <> " " Then
ExtName = LCase(GetExtensionName(s))
BaseName = UCase(GetBaseName(s))
End If
Debug.Print data_path & "\" & BaseName & "." & ExtName
i = 2
done = False
Do While ASheets.Cells(i, 1).Value2 <> ""
If UCase(ASheets.Cells(i, 1).Value2) = BaseName Then
done = True
Exit Do
End If
i = i + 1
Loop
outpath = data_outpath
If done Then
bzjh = ASheets.Cells(i, 2).Value2
If fs.FileExists(data_outpath & "\" & bzjh & ".las") Then
i = 1
Exists = True
Do While Exists
newd$ = "\Las(" & Trim(i) & ")"
If Not fs.FolderExists(data_outpath & newd$) Then
fs.CreateFolder (data_outpath & newd$)
outpath = data_outpath & newd$
Exists = False
Else
If Not fs.FileExists(data_outpath & newd$ & "\" & bzjh & ".las") Then
outpath = data_outpath & newd$
Exists = False
End If
End If
i = i + 1
Loop
End If
Select Case UCase(ExtName)
Case "ASC"
ASC_to_las data_path, outpath, BaseName, ExtName, bzjh
Case "TXT"
TXT_to_las data_path, outpath, BaseName, ExtName, bzjh
Case "LAS"
las_to_las data_path, outpath, BaseName, ExtName, bzjh
Case Else
Stop
End Select
End If
Next f1
End Sub
Sub las_to_las(data_path, data_outpath, BaseName, ExtName, bzjh)
Open data_outpath & "\" & bzjh & ".las" For Output As #1
Open data_path & "\" & BaseName & "." & ExtName For Input As #2
Do While Not EOF(2)
Line Input #2, a$
Print #1, a$
Loop
Close #1, #2
End Sub
'进行转换, ASC文件
Sub TXT_to_las(data_path, data_outpath, BaseName, ExtName, bzjh)
Dim qx(100) As String, QX_Data(100) As Single, qx_unit(100) As String, qx_fl(100) As Boolean
Dim loc As Long
Dim d_dep, d_dep0
txtline = 0
Set qxSheets = Work_Book.Sheets("qx")
Open data_path & "\" & BaseName & "." & ExtName For Input As #2
loc = 1
Do While Not EOF(2)
Line Input #2, a$
txtline = txtline + 1
If InStr(UCase(a$), "DEP") <> 0 Then
find_qxName a$, qx(), qx_max, done
If done = True Then Exit Do
End If
Loop
For k = 1 To qx_max
If Left(qx(k), 3) = "DEP" Then
DEP_LOC = k
Exit For
End If
Next k
For k = 1 To qx_max
qx_fl(k) = False
Next k
For k = 1 To qx_max
i = 2
done = False
Do While qxSheets.Cells(i, 1).Value2 <> ""
If UCase(qxSheets.Cells(i, 1).Value2) = UCase(qx(k)) Then
done = True
Exit Do
End If
i = i + 1
Loop
If Not done Then
qxSheets.Cells(i, 1).Value2 = UCase(qx(k))
qxSheets.Cells(i, 6).Value2 = BaseName & "." & ExtName
Else
qx(k) = qxSheets.Cells(i, 2).Value2
qx_unit(k) = qxSheets.Cells(i, 3).Value2
If Trim(UCase(qxSheets.Cells(i, 4).Value2)) = "Y" Then qx_fl(k) = True
End If
Next k
b$ = ""
Do While b$ = ""
loc_data = loc
Line Input #2, a$
txtline = txtline + 1
b$ = Replace(Replace(a$, "=", ""), " ", "")
Loop
Find_qxdate a$, QX_Data(), qx_max, done
dep = QX_Data(DEP_LOC)
d_dep0 = 0
dep_min = dep
dep_max = dep
Do While Not EOF(2)
Line Input #2, a$
Find_qxdate a$, QX_Data(), qx_max, done
If Not done Then Exit Do
d_dep = QX_Data(DEP_LOC) - dep
If d_dep0 <> 0 Then
If d_dep <> d_dep0 Then Stop
d_dep0 = d_dep
End If
dep = QX_Data(DEP_LOC)
If dep_min > dep Then dep_min = dep
If dep_max < dep Then dep_max = dep
Loop
Close #2
Open data_outpath & "\" & bzjh & ".las" For Output As #1
Open data_path & "\" & BaseName & "." & ExtName For Input As #2
Print #1, "~Version Information Block"
Print #1, " VERS. 2.00: CWLS LOG ASCII STANDARD - VERSION 2.000000"
Print #1, " WRAP. NO: One Line Per Depth Step"
Print #1, "#"
Print #1, "~Well Information Block"
Print #1, "#MNEM.UNIT Data Information"
Print #1, "#---------- ------------------------------------------ ----------------"
Print #1, "STRT .M "; Format(dep_min, ".0000"); ": START DEPTH"
Print #1, "STOP .M "; Format(dep_max, ".0000"); ": STOP DEPTH"
Print #1, "STEP .M "; Format(d_dep, ".0000"); ": STEP"
Print #1, "NULL . -999999.000: NULL VALUE"
Print #1, "WELL . "; bzjh; ": WELL"
Print #1, "~Curve Information Block "
Print #1, "#MNEM.UNIT API CODE Curve Description"
Print #1, "#---------- ---------------- -----------"
For i = 1 To qx_max
If qx_fl(i) Then
Print #1, Format(qx(i), "!@@@@@@@"); "."; Format(qx_unit(i), "!@@@@@@@@@@@@@@@@@@@@@@@@@ "); ":"
End If
Next i
Print #1, "~A ";
For i = 1 To qx_max
If qx_fl(i) Then
Print #1, Format(qx(i), "!@@@@@@@@@@");
End If
Next i
Print #1,
For i = 1 To txtline - 1
Line Input #2, a$
Next i
Do While Not EOF(2)
Line Input #2, a$
Find_qxdate a$, QX_Data(), qx_max, done
For i = 1 To qx_max
If qx_fl(i) Then
Print #1, Format(Format(QX_Data(i), "0.000"), "@@@@@@@@@@");
End If
Next i
Print #1,
Loop
Close #1, #2
End Sub
'进行转换, ASC文件
Sub ASC_to_las(data_path, data_outpath, BaseName, ExtName, bzjh)
Dim qx(100) As String, QX_Data(100) As Single, qx_unit(100) As String, qx_fl(100) As Boolean
Dim loc As Long
Dim d_dep, d_dep0
Set qxSheets = Work_Book.Sheets("qx")
Open data_path & "\" & BaseName & "." & ExtName For Binary As #2
loc = 1
Do While Not EOF(2)
a$ = Inputline(2, loc)
find_qxName a$, qx(), qx_max, done
If done = True Then Exit Do
Loop
For k = 1 To qx_max
If Left(qx(k), 3) = "DEP" Then
DEP_LOC = k
Exit For
End If
Next k
For k = 1 To qx_max
qx_fl(k) = False
Next k
For k = 1 To qx_max
i = 2
done = False
Do While qxSheets.Cells(i, 1).Value2 <> ""
If UCase(qxSheets.Cells(i, 1).Value2) = UCase(qx(k)) Then
done = True
Exit Do
End If
i = i + 1
Loop
If Not done Then
qxSheets.Cells(i, 1).Value2 = UCase(qx(k))
qxSheets.Cells(i, 6).Value2 = BaseName & "." & ExtName
Else
qx(k) = qxSheets.Cells(i, 2).Value2
qx_unit(k) = qxSheets.Cells(i, 3).Value2
If Trim(UCase(qxSheets.Cells(i, 4).Value2)) = "Y" Then qx_fl(k) = True
End If
Next k
loc_data = loc
a$ = Inputline(2, loc)
Find_qxdate a$, QX_Data(), qx_max, done
dep = QX_Data(DEP_LOC)
d_dep0 = 0
dep_min = dep
dep_max = dep
Do While Not EOF(2)
a$ = Inputline(2, loc)
Find_qxdate a$, QX_Data(), qx_max, done
If Not done Then Exit Do
d_dep = QX_Data(DEP_LOC) - dep
If d_dep0 <> 0 Then
If d_dep <> d_dep0 Then Stop
d_dep0 = d_dep
End If
dep = QX_Data(DEP_LOC)
If dep_min > dep Then dep_min = dep
If dep_max < dep Then dep_max = dep
Loop
Close #2
Open data_outpath & "\" & bzjh & ".las" For Output As #1
Open data_path & "\" & BaseName & "." & ExtName For Binary As #2
Print #1, "~Version Information Block"
Print #1, " VERS. 2.00: CWLS LOG ASCII STANDARD - VERSION 2.000000"
Print #1, " WRAP. NO: One Line Per Depth Step"
Print #1, "#"
Print #1, "~Well Information Block"
Print #1, "#MNEM.UNIT Data Information"
Print #1, "#---------- ------------------------------------------ ----------------"
Print #1, "STRT .M "; Format(dep_min, ".0000"); ": START DEPTH"
Print #1, "STOP .M "; Format(dep_max, ".0000"); ": STOP DEPTH"
Print #1, "STEP .M "; Format(d_dep, ".0000"); ": STEP"
Print #1, "NULL . -999999.000: NULL VALUE"
Print #1, "WELL . "; bzjh; ": WELL"
Print #1, "~Curve Information Block "
Print #1, "#MNEM.UNIT API CODE Curve Description"
Print #1, "#---------- ---------------- -----------"
For i = 1 To qx_max
If qx_fl(i) Then
Print #1, Format(qx(i), "!@@@@@@@"); "."; Format(qx_unit(i), "!@@@@@@@@@@@@@@@@@@@@@@@@@ "); ":"
End If
Next i
Print #1, "~A ";
For i = 1 To qx_max
If qx_fl(i) Then
Print #1, Format(qx(i), "!@@@@@@@@@@");
End If
Next i
Print #1,
loc = loc_data
Do While Not EOF(2)
a$ = Inputline(2, loc)
Find_qxdate a$, QX_Data(), qx_max, done
For i = 1 To qx_max
If qx_fl(i) Then
Print #1, Format(Format(QX_Data(i), "0.000"), "@@@@@@@@@@");
End If
Next i
Print #1,
Loop
Close #1, #2
End Sub
'从字符串中分析出数据，并存入 QX_Data() 数组中
Sub Find_qxdate(Title$, QX_Data() As Single, qx_max, done)
done = False
a$ = Trim(Title$)
l = Len(a$)
i = 1
For j = 1 To l
b$ = Mid(a$, j, 1)
If b$ = " " Then
If fl Then
QX_Data(i) = Val(c$)
i = i + 1
c$ = ""
fl = False
End If
Else
c$ = c$ + b$
fl = True
End If
Next j
If qx_max = i Then done = True
End Sub
'从字符串中分析出测井曲线名称，并存入 QX() 数组中
Sub find_qxName(Title$, qx() As String, qx_max, done)
done = False
a$ = Trim(Title$)
l = Len(a$)
i = 1
For j = 1 To l
b$ = Mid(a$, j, 1)
If b$ = " " Then
If fl Then
i = i + 1
qx(i) = ""
fl = False
End If
Else
qx(i) = qx(i) + b$
fl = True
End If
Next j
qx_max = i
done = True
End Sub
'对UNIX格式文本文件读取行字符串，类似于DOS下的lineinput
Function Inputline(filenum, loc)
Dim b As String * 1
a$ = ""
If EOF(filenum) Then
Inputline = a$
Exit Function
End If
Get #filenum, loc, b
loc = loc + 1
Do While b <> Chr(13) And b <> Chr(10)
a$ = a$ + b
If EOF(filenum) Then
Inputline = a$
Exit Function
End If
Get #filenum, loc, b
loc = loc + 1
Loop
If b = Chr(13) Then
If EOF(filenum) Then
Inputline = a$
Exit Function
End If
Get #filenum, loc, b
If b = Chr(10) Then
loc = loc + 1
End If
End If
Inputline = a$
End Function
'得到文件名的扩展名
Function GetExtensionName(fn)
l0 = Len(fn)
l = l0 + 1
Do
l = l - 1
Loop Until (l = 1 Or Mid(fn, l, 1) = ".")
If l = 1 Then
GetExtensionName = ""
Else
GetExtensionName = Right(fn, l0 - l)
End If
End Function
'得到文件名的主文件名
Function GetBaseName(fn)
l0 = Len(fn)
l = l0 + 1
Do
l = l - 1
Loop Until (l = 1 Or Mid(fn, l, 1) = ".")
If l = 1 Then
GetBaseName = fn
Else
GetBaseName = Left(fn, l - 1)
End If
End Function
