|
昨天幫領(lǐng)導(dǎo)做了一個TOOLS，功能是把一個文件夾下的所有TXT文件，按照特定的方式讀取出來，進(jìn)行篩選，
由于我覺得篩選邏輯比較復(fù)雜，所以我采用了ACCESS的讀取方式，把TXT內(nèi)容讀取到數(shù)據(jù)庫中，然后通過SQL問進(jìn)行篩選。上來就遇到了問題ACCESS的VBA讀取TXT讀進(jìn)去的都亂碼，嘗試了各種方式，都是如此，后來靈機一動放棄了文件的單純讀取，通過讀取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
|
