VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "File"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" _
    (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
Private Declare Function CreateFileMapping Lib "kernel32.dll" Alias "CreateFileMappingA" _
    (hFile As Long, lpSecurityAttributes As Any, _
    ByVal flProtect As Long, ByVal dwMaximumSizeHigh, _
    ByVal dwMaximumSizeLow, ByVal lpName As String) As Long
Private Declare Function ReadFile Lib "kernel32.dll" _
    (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32.dll" _
    (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Boolean
Private Declare Function SetFilePointer Lib "kernel32.dll" Alias "SetFilePointerA" _
    (hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, _
    ByVal dwMoveMethod As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" _
    (ByVal hObject As Long) As Long
'Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" _
    (ByVal dwFlags As Long, ByVal lpSource As Any, ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, lpBuffer As String, ByVal Arguments As Any) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
    (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _
    Arguments As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)


Public Enum FileOps
    fileRead
    fileWrite
    fileBoth
End Enum

Private Type SecurityAttributes
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Boolean
End Type

Private Type Overlapped
    Internal As Long
    InternalHigh As Long
    Offset As Long
    OffsetHigh As Long
    hEvent As Long
End Type

Public Ready As Boolean
Private H&, Position&

Private Const GENERIC_READ  As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const GENERIC_ALL   As Long = &H10000000
Private Const FILE_SHARE_READ       As Long = &H1
Private Const FILE_SHARE_WRITE      As Long = &H2
Private Const FILE_SHARE_DELETE     As Long = &H4

Private Const FILE_ATTRIBUTE_READONLY           As Long = &H1
Private Const FILE_ATTRIBUTE_HIDDEN         As Long = &H2
Private Const FILE_ATTRIBUTE_SYSTEM         As Long = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY      As Long = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE            As Long = &H20
Private Const FILE_ATTRIBUTE_DEVICE         As Long = &H40
Private Const FILE_ATTRIBUTE_NORMAL         As Long = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY      As Long = &H100
Private Const FILE_ATTRIBUTE_SPARSE_FILE        As Long = &H200
Private Const FILE_ATTRIBUTE_REPARSE_POINT      As Long = &H400
Private Const FILE_ATTRIBUTE_COMPRESSED     As Long = &H800
Private Const FILE_ATTRIBUTE_OFFLINE            As Long = &H1000
Private Const FILE_ATTRIBUTE_NOT_CONTENT_INDEXED    As Long = &H2000
Private Const FILE_ATTRIBUTE_ENCRYPTED      As Long = &H4000
Private Const FILE_ATTRIBUTE_VALID_FLAGS        As Long = &H7FB7
Private Const FILE_ATTRIBUTE_VALID_SET_FLAGS        As Long = &H31A7

Private Const CREATE_ALWAYS   As Long = &H2
Private Const OPEN_ALWAYS   As Long = &H4
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const INVALID_SET_FILE_POINTER As Long = -1

Private Const FILE_BEGIN As Long = 0
Private Const FILE_CURRENT As Long = 1
Private Const FILE_END As Long = 2

Private Const FORMAT_MESSAGE_FROM_SYSTEM& = 4096

Private Sub Class_Initialize()
On Error Resume Next
    H = INVALID_HANDLE_VALUE
    Ready = False
End Sub

Private Sub Class_Terminate()
On Error Resume Next
    If H <> INVALID_HANDLE_VALUE Then _
        CloseHandle H
End Sub


Public Function Load(Filename As String, Operation As FileOps, Optional AlwaysCreate As Boolean = False) As Boolean
    Dim cfo&, sm&, cd&, SA As SecurityAttributes
    Select Case Operation
        Case fileRead
            cfo = GENERIC_READ
            sm = FILE_SHARE_READ
            cd = OPEN_ALWAYS
        Case fileWrite
            cfo = GENERIC_WRITE
            sm = FILE_SHARE_WRITE
            If AlwaysCreate Then
                cd = CREATE_ALWAYS
            Else
                cd = OPEN_ALWAYS
            End If
        Case fileBoth
            cfo = GENERIC_ALL
            sm = FILE_SHARE_READ Or FILE_SHARE_WRITE
            If AlwaysCreate Then
                cd = CREATE_ALWAYS
            Else
                cd = OPEN_ALWAYS
            End If
    End Select
    With SA
        .lpSecurityDescriptor = 0&
        .bInheritHandle = False
        .nLength = Len(SA)
    End With
    H = CreateFile(Filename, cfo, sm, ByVal 0&, cd, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
    If H = INVALID_HANDLE_VALUE Then
        Load = False
        Exit Function
    End If
    Load = True
    Ready = True
End Function

Public Function Unload() As Boolean
    If CloseHandle(H) = 0 Then
        Unload = False
    Else
        Unload = True
        H = INVALID_HANDLE_VALUE
    End If
End Function

Public Function ReadDWORD() As Long
    Dim Rec As String * 4
    Dim BR As Long, rVal As Long
    If (ReadFile(H, ByVal Rec, 4, BR, ByVal 0&)) Then
        CopyMemory rVal, ByVal Rec, 4
        ReadDWORD = rVal
    End If
    Position = Position + 4
End Function

Public Function ReadWORD() As Integer
    Dim Rec As String * 2
    Dim BR As Long, rVal As Integer
    If (ReadFile(H, ByVal Rec, 2, BR, ByVal 0&)) Then
        CopyMemory rVal, ByVal Rec, 2
        ReadWORD = rVal
    End If
    Position = Position + 2
End Function

Public Function ReadByte() As Byte
    Dim Rec As String * 1
    Dim BR As Long, rVal As Byte
    If (ReadFile(H, ByVal Rec, 1, BR, ByVal 0&)) Then
        CopyMemory rVal, ByVal Rec, 1
        ReadByte = rVal
    End If
    Position = Position + 1
End Function

Public Function ReadString() As String
    Dim rVal$, CC As String * 1, Length&, BytesRead&, TBR&, Cont As Boolean
    Cont = True
    CC = vbNullChar
    While Cont
        If (ReadFile(H, CC, 1, TBR, ByVal 0&)) Then
            If CC = vbNullChar Then
                Cont = False
                BytesRead = BytesRead + 1
            Else
                rVal = rVal & CC
                BytesRead = BytesRead + 1
            End If
        Else
            Position = Position + BytesRead
            ReadString = rVal
            Exit Function
        End If
    Wend
    Position = Position + BytesRead
    ReadString = rVal
End Function

Public Function ReadLine() As String
    'Should support Windows, UNIX, and Mac line endings.
    Dim rVal$, CC As String, CC2 As String, Length&, BytesRead&, TBR&, Cont As Boolean
    Cont = True
    While Cont
        CC = vbNullChar
        If (ReadFile(H, ByVal CC, 1, TBR, ByVal 0&) > 0) Then
            If CC = vbCr Then
                Cont = False
                BytesRead = BytesRead + 1
                CC2 = vbNullChar
                If ReadByte() = &HA Then 'Line Feed
                    BytesRead = BytesRead + 1
                Else
                    Move -1
                End If
                'If (ReadFile(H, CC2, 1, TBR, ByVal 0&)) Then
                '    If CC = vbLf Then
                '        BytesRead = BytesRead + 1
                '    Else
                '        Move -1
                '    End If
                'Else
                '    Position = Position + BytesRead
                '    ReadLine = rVal
                '    Exit Function
                'End If
            ElseIf CC = vbLf Then
                Cont = False
                BytesRead = BytesRead + 1
            ElseIf CC = vbNullChar Then
                Cont = False
            Else
                rVal = rVal & CC
                BytesRead = BytesRead + 1
            End If
        Else
            Cont = False
        End If
    Wend
    Position = Position + BytesRead
    ReadLine = rVal
End Function

Public Function Move(Distance As Long) As Boolean
    If (SetFilePointer(H, Distance, Null, FILE_CURRENT) <> INVALID_SET_FILE_POINTER) Then
        Move = True
        Position = Position + Distance
    Else
        Move = False
    End If
End Function

Public Function MoveTo(mvPosition As Long) As Boolean
    If (SetFilePointer(H, mvPosition, Null, FILE_BEGIN) <> INVALID_SET_FILE_POINTER) Then
        MoveTo = True
        Position = mvPosition
    Else
        MoveTo = False
    End If
End Function

Public Function WriteNonNTString(ByVal Data As String) As Boolean
    Dim x&
    WriteNonNTString = WriteFile(H, ByVal Data, Len(Data), x, ByVal 0&)
End Function

Public Function WriteString(ByVal Data As String) As Boolean
    Dim x&
    WriteString = WriteFile(H, ByVal Data & vbNullChar, Len(Data) + 1, x, ByVal 0&)
    Debug.Print "WS: " & x
End Function

Public Function WriteNTString(ByVal Data As String) As Boolean
    WriteNTString = WriteString(Data)
End Function

Public Function WriteDWORD(ByVal Data As Long) As Boolean
    Dim x&
    WriteDWORD = WriteFile(H, Data, 4, x, ByVal 0&)
End Function

Public Function WriteWORD(ByVal Data As Integer) As Boolean
    Dim x&
    WriteWORD = WriteFile(H, Data, 2, x, ByVal 0&)
End Function

Public Function WriteByte(ByVal Data As Byte) As Boolean
    Dim x&
    WriteByte = WriteFile(H, Data, 1, x, ByVal 0&)
End Function

Public Function GetErrorMessage() As String
    Dim rVal As String, x&, LDE&
    LDE = Err.LastDllError
    rVal = String$(255, vbNullChar)
    x = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, LDE, ByVal 0&, _
        rVal, 255, ByVal 0&)
    If x > 0 Then _
        GetErrorMessage = Left$(rVal, x) & " (#" & LDE & ")"
End Function

Public Function GetPosition() As Long
    GetPosition = Position
End Function
