|
昨天帮领导做了一个TOOLS，功能是把一个文件夹下的所有TXT文件，按照特定的方式读取出来，进行筛选，
由于我觉得筛选逻辑比较复杂，所以我采用了ACCESS的读取方式，把TXT内容读取到数据库中，然后通过SQL问进行筛选。上来就遇到了问题ACCESS的VBA读取TXT读进去的都乱码，尝试了各种方式，都是如此，后来灵机一动放弃了文件的单纯读取，通过读取EXCEL的方式读取，居然成功了，分享一下给大家。
Option Compare Database
Private Sub 実行_Click()
' Dim txtLine As String
' Dim FileObj As Object
' Dim TextObj As Object
' Dim FilePath
' Dim MyPath$, MyFile$
' Dim fs, f
'Const ForReading = 1, ForWriting = 2, ForAppending = 8, TristateFalse = 0
'
' Set fs = CreateObject("Scripting.FileSystemObject")
' Set f = fs.OpenTextFile("D:\tools\result.txt", 8, True, TristateFalse)
'
' FilePath = txtPATH.Value
'
' MyPath = FilePath & "\*.*"
' MyFile = Dir(MyPath)
' Do
' Debug.Print MyFile
' If MyFile <> "" Then
' Set FileObj = CreateObject("Scripting.FileSystemObject")
' Set TextObj = FileObj.OpenTextFile(FilePath & "\" & MyFile, ForReading, TristateTrue)
' Do While Not TextObj.AtEndOfLine
' txtLine = Trim(TextObj.ReadLine)
' 'If InStr(txtLine, "タイプ作成中") > 0 Then
' f.writeline txtLine & vbCrLf
' 'End If
' Loop
' End If
' MyFile = Dir
' Loop Until MyFile = ""
' f.Close
'--------------------------------------------------------------------------------------
' Dim txtLine As String
' Dim FileObj As Object
' Dim TextObj As Object
' Dim FilePath
' Dim MyPath$, MyFile$
' Dim fs, f
'Const ForReading = 1, ForWriting = 2, ForAppending = 8, TristateFalse = 0
'
' Set fs = CreateObject("Scripting.FileSystemObject")
' Set f = fs.OpenTextFile("D:\tools\result.txt", 8, True, TristateFalse)
'
' FilePath = txtPATH.Value
'
' MyPath = FilePath & "\*.*"
' MyFile = Dir(MyPath)
' Do
' Debug.Print MyFile
' If MyFile <> "" Then
' Dim strRtn As String
' Set stm = New ADODB.Stream
' stm.Type = 2
' stm.Mode = 3
' stm.Charset = "UTF-8"
' stm.Open
' stm.LoadFromFile FilePath & "\" & MyFile
' strRtn = stm.ReadText
' stm.Close
' Set stm = Nothing
' ReadFromFileADO = strRtn
' End If
' MyFile = Dir
' Loop Until MyFile = ""
' f.Close
'-----------------------------------
' Dim txtLine As String
' Dim FileObj As Object
' Dim TextObj As Object
' Dim FilePath
' Dim MyPath$, MyFile$
' Dim fs, f
'Const ForReading = 1, ForWriting = 2, ForAppending = 8, TristateFalse = 0
'
' Set fs = CreateObject("Scripting.FileSystemObject")
' Set f = fs.OpenTextFile("D:\tools\result.txt", 8, True, TristateFalse)
'
' FilePath = txtPATH.Value
'
' MyPath = FilePath & "\*.*"
' MyFile = Dir(MyPath)
' Do
' Debug.Print MyFile
' If MyFile <> "" Then
' Dim ff As String
' Dim Txt() As String
' Dim i As Integer
' i = 0
'
' ff = FilePath & "\" & MyFile
' Open ff For Input As #1
' Do Until EOF(1)
' Line Input #1, txtLine
'
' i = i + 1
' Loop
' Close #1
' End If
' MyFile = Dir
' Loop Until MyFile = ""
Dim txtLine As String
Dim FileObj As Object
Dim TextObj As Object
Dim FilePath
Dim MyPath$, MyFile$
Dim fs, f
Dim EXEファイル名(1 To 10000) As String
Dim 机能(1 To 10000) As String
Dim PBL名(1 To 10000) As String
Dim Object名(1 To 10000) As String
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Set xlApp = New Excel.Application
Dim sheet As Excel.Worksheet
Dim FLAG As Integer
Const ForReading = 1, ForWriting = 2, ForAppending = 8, TristateFalse = 0
Set fs = CreateObject("Scripting.FileSystemObject")
FLAG = 0
FilePath = txtPATH.Value
MyPath = FilePath & "\*.*"
MyFile = Dir(MyPath)
Do
Debug.Print MyFile
If MyFile <> "" Then
Set xlBook = xlApp.Workbooks.Open(FilePath & "\" & MyFile)
Set sheet = xlBook.Worksheets(1)
Dim ss As String
Dim a
For a = 1 To sheet.UsedRange.Rows.count - 1
ss = sheet.Cells(a, 1)
If InStr(ss, "タイプ作成中") > 0 Then
FLAG = 1
If InStr(ss, "pbl_exe_ver11a") = 0 Then
ss = Mid(ss, InStr(ss, "pbl_exe_ver11") + Len("pbl_exe_ver11") + 1)
Else
ss = Mid(ss, InStr(ss, "pbl_exe_ver11a") + Len("pbl_exe_ver11a") + 1)
End If
EXEファイル名(a) = Left(MyFile, InStr(MyFile, ".") - 1)
If InStr(ss, "\") = 0 Then
' 机能(a) = "共通"
' PBL名(a) = Left(ss, InStr(ss, "(") - 1)
' Object名(a) = Left(Mid(ss, InStr(ss, "(") + 1), Len(Mid(ss, InStr(ss, "(") + 1)) - 7)
Else
机能(a) = Left(ss, InStr(ss, "\") - 1)
PBL名(a) = Left(Split(ss, "\")(1), InStr(Split(ss, "\")(1), "(") - 1)
Object名(a) = Left(Split(ss, "(")(1), InStr(Split(ss, "(")(1), ")") - 1)
DoCmd.SetWarnings False
DoCmd.RunSQL ("INSERT INTO Logtable(EXEファイル名,机能,PBL名,Object名) VALUES('" & EXEファイル名(a) & "','" & 机能(a) & "','" & PBL名(a) & "','" & Object名(a) & "')")
DoCmd.SetWarnings True
End If
ElseIf FLAG = 1 Then
FLAG = 0
Exit For
End If
Next a
End If
MyFile = Dir
Loop Until MyFile = ""
Set sheet = Nothing
xlBook.Close (True)
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
MsgBox "Success"
AllDataのサブフォーム.Requery
'Dim i As Long
'i = Shell("cmd.exe /c taskkill /f /im excel.exe", vbNormalFocus)
' Dim i As Long
' Dim r As Long
' Dim p As Long
' i = Shell("notepad.exe", vbNormalFocus)
' p = OpenProcess(SYNCHRONIZE, False, i)
' r = WaitForSingleObject(p, INFINITE)
' r = CloseHandle(p)
End Sub
|
