Re: using Line Input

Tech-Archive recommends: Repair Windows Errors & Optimize Windows Performance

On Fri, 2 Mar 2007 12:52:25 -0500, "Robert Morley"
<rmorley@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote:

It gets a bit more tricky, but you can try reading the file in chunks and
splitting each of the chunks. The tricky part (okay, not THAT tricky) is in
making sure that you combine the last string in one chunk with the first
string in the next chunk. To my knowledge, Line Input works great on
"normal" text files, but if you want to step outside of that, you'll have
problems. Manual parsing is probably how you're going to have to do it,
unless maybe there's a third-party DLL that works better; I've never looked
at any, so I wouldn't know.

Here is a Class that encapsulates what Robert is suggesting.

Save it as cRFStrm.cls

Usage:
Dim oRFS As cReadFileStream

Set oRFS = New cReadFileStream
If oRFS.Create( "c:\test.txt" ) = False Then
' bug out
End If

While oRFS.EofFlag = False
L$ = oRFS.ReadDelineatedLine
....
Wend
oRFS.Free (Optional)




VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cReadFileStream"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' 2/8/01 JF
' 3/8/01 JF - Block Read Added - watch for Block > File Size
'

Private Type TCMN
FileName As String
FileSize As Long
Delin As String
Buffer As String
BufferLen As Long
BufferPos As Long
BytesDone As Long
EofFlag As Boolean
Channel As Integer
End Type

Private cmn As TCMN

' ---
Private Sub Class_Initialize()
cmn.Delin = vbCrLf
cmn.BufferLen = 100000
End Sub

' ---
Public Function Create(FileName$) As Boolean

cmn.FileName = FileName
Create = False
cmn.Buffer = ""
cmn.Channel = 0
cmn.EofFlag = False
cmn.BufferPos = 1
cmn.BytesDone = 0
' ---
If FileExists(FileName$) = False Then
MsgBox "cReadFileStream: " + FileName$ _
+ "File not Found"
Exit Function
End If
' ---
If FileExists(FileName$) Then
cmn.FileSize = FileLen(cmn.FileName)
cmn.Channel = FreeFile
Open FileName For Binary Access Read As #cmn.Channel
Create = True
End If
End Function

' ---
Public Function ReadDelineatedLine() As String
Dim Q&, L&

If cmn.Channel = 0 Then
MsgBox "cReadFileStream - ReadLine - but file not Open"
cmn.EofFlag = True
Exit Function
End If
' ---
If cmn.EofFlag Then
MsgBox "cReadFileStream - Read Past End of File"
Exit Function
End If
' ---
If InStr(cmn.BufferPos, cmn.Buffer, cmn.Delin) = 0 Then
Call LS_FillBuffer
' --- When File completely Read then append Delin if Needed
If cmn.BytesDone = cmn.FileSize Then
If Right$(cmn.Buffer, Len(cmn.Delin)) <> cmn.Delin Then
cmn.Buffer = cmn.Buffer + cmn.Delin
End If
End If
End If

' ---
Q = InStr(cmn.BufferPos, cmn.Buffer, cmn.Delin)
If Q Then
L = Q - cmn.BufferPos
ReadDelineatedLine = Mid$(cmn.Buffer, cmn.BufferPos, L)
cmn.BufferPos = Q + Len(cmn.Delin)
End If
If Q = 0 Then
MsgBox "cReadFileStream - Read - Unexpected Error" _
+ vbCrLf + "Delineator not Found"
End If

' --- Was this the last Field of the Last Buffer
If cmn.BytesDone >= cmn.FileSize Then
If Q >= Len(cmn.Buffer) - Len(cmn.Delin) Then
cmn.EofFlag = True
End If
End If
End Function

' ---
Public Sub ReadBlock(Block$)
Dim BlockLen&, Q&

If cmn.Channel = 0 Then
MsgBox "cReadFileStream - ReadBlock - but file not Open"
cmn.EofFlag = True
Exit Sub
End If
' ---
If cmn.EofFlag Then
MsgBox "cReadFileStream - Read Past End of File"
Exit Sub
End If

' ---
BlockLen& = Len(Block$)

' --- Do we need to fill the Buffer
If (cmn.BufferPos + BlockLen) > Len(cmn.Buffer) Then
If BlockLen > cmn.BufferLen Then ' increase buffer size
cmn.BufferLen = cmn.BufferPos + BlockLen
End If
Call LS_FillBuffer
End If

' --- If insufficient Data left
Q = Len(cmn.Buffer$) - cmn.BufferPos + 1 ' Bytes Left
If BlockLen > Q Then
Block$ = Space$(Q)
BlockLen = Q
End If

' --- Copy the data
Mid$(Block$, 1, BlockLen) = Mid$(cmn.Buffer$, cmn.BufferPos,
BlockLen)
cmn.BufferPos = cmn.BufferPos + BlockLen

' --- Was this the last Field of the Last Buffer
If cmn.BytesDone >= cmn.FileSize Then
If cmn.BufferPos > Len(cmn.Buffer$) Then
cmn.EofFlag = True
End If
End If

End Sub


' ---
Public Function EofFlag() As Boolean
EofFlag = cmn.EofFlag
End Function

' ---
Public Function Size() As Long
Size = cmn.FileSize
End Function

' ---
Public Sub Free()
If cmn.Channel <> 0 Then
Close #cmn.Channel
cmn.Channel = 0
End If
End Sub

' ---
Private Sub LS_FillBuffer()
Dim Hold$, Q&

' --- First time in cmn.Buffer = ""
Hold$ = Mid$(cmn.Buffer, cmn.BufferPos)

If cmn.BytesDone >= cmn.FileSize Then
Exit Sub
End If

' ---
If Len(cmn.Buffer) < cmn.BufferLen Then
cmn.Buffer = Space$(cmn.BufferLen)
End If

' --- Reduce Buffer Size at End of File
Q = cmn.FileSize - cmn.BytesDone
If Q < Len(cmn.Buffer) Then
cmn.Buffer = Space$(Q)
End If

' --- Read a Chunk
Get #cmn.Channel, cmn.BytesDone + 1, cmn.Buffer
cmn.BytesDone = cmn.BytesDone + Len(cmn.Buffer)

' --- Add leftover chunk if needed
If Len(Hold$) Then
cmn.Buffer = Hold + cmn.Buffer
End If
' ---
cmn.BufferPos = 1

End Sub

Private Sub Class_Terminate()
Me.Free
End Sub

'
' Support Routines
'
Function FileExists(Fle$) As Boolean
Dim Q%
On Error Resume Next
Q = GetAttr(Fle$)
If Err = 0 Then
If (Q And vbDirectory) = 0 Then
FileExists = True
End If
End If
Err.Clear
End Function


.

Relevant Pages

  • Re: Writing Access functions
    ... Otherwise, create a sub. ... Control sources, Macros (thought the only one you should be using is the ... Public Function NameFromIDAs String ...
    (microsoft.public.access.modulesdaovba)
  • Re: Date & Time
    ... > Private Sub Userform_Initialize ... > ByVal lpWindowName As String) As Long ... > Public Function cbkRoutine(ByVal Window_hWnd As Long, ... > Dim CurrentTime As String ...
    (microsoft.public.excel.newusers)
  • Re: using Line Input
    ... string in the next chunk. ... Private Sub Class_Initialize ... Public Function ReadDelineatedLine() As String ... ' --- Was this the last Field of the Last Buffer ...
    (microsoft.public.vb.general.discussion)
  • Re: Bind Custom Class to windows form datagrid.
    ... Implementing it in the derived class won't work because ... >> Private mstrFirstName As String ... >> Public Sub New ... >> Public Function AddAs Integer ...
    (microsoft.public.dotnet.framework.windowsforms.databinding)
  • Re: Automatically up date time in a cell
    ... > ByVal lpWindowName As String) As Long ... > Dim CurrentTime As String ... > Sub StartClock() ... > Public Function fncWindowsTimer ...
    (microsoft.public.excel.misc)