Function GetTextFromFile(ByVal FileName As String, ByRef TextArray() As String) As Long
Dim hFile As Long
Dim lngCount As Long
Dim bytFile() As Byte
Dim strFile As String
Dim RegExp As Object
Dim Matchs As Object
On Error Resume Next
lngCount = FileLen(FileName)
If lngCount > 0 Then
Set RegExp = CreateObject("VBScript.RegExp")
If Not (RegExp Is Nothing) Then
hFile = FreeFile
ReDim bytFile(0 To lngCount - 1)
Open FileName For Binary As hFile
Get hFile, , bytFile()
Close hFile
strFile = StrConv(bytFile(), vbUnicode)
Erase bytFile
lngCount = 0
With RegExp
.Global = True
.IgnoreCase = True
.Pattern = "\b0{3}2\d+"
Set Matchs = .Execute(strFile)
End With
If Matchs.Count < 1 Then
GetTextFromFile = 0
Else
With Matchs
ReDim TextArray(0 To .Count - 1)
For lngCount = 0 To .Count - 1
TextArray(lngCount) = "'" & Mid$(.Item(lngCount), 5)
Next lngCount
End With
GetTextFromFile = lngCount
End If
Set Matchs = Nothing
Set RegExp = Nothing
Else
GetTextFromFile = -2
End If
Else
GetTextFromFile = -1
End If
End Function
Sub Test()
Dim TextArray() As String
Dim FileName As String
Dim I As Long
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Text File", "*.TXT,*.DAT"
.FilterIndex = 1
If .Show = -1 Then
FileName = .SelectedItems(1)
I = GetTextFromFile(FileName, TextArray)
If I > 0 Then
Range("A1").Resize(I, 1).Value = Application.WorksheetFunction.Transpose(TextArray)
End If
End If
End With
End Sub
