' 撰寫人：Devil(璉璉)  E-Mail: qvb3377@ms5.hinet.net  僅供學術測試使用，引用請註明原出處
' --------------------------------------------------------------------------------------

Public Enum enuFileAccess
  Default = 0
  ReadOnly = 1
  ReadWrite = 2
  WriteOnly = 3
End Enum

Public Enum W32F_Errors
  W32F_UNKNOWN_ERROR = 45600
  W32F_FILE_ALREADY_OPEN
  W32F_PROBLEM_OPENING_FILE
  W32F_FILE_ALREADY_CLOSED
  W32F_Problem_seeking
  W32F_Problem_Source_Close
End Enum

Private Const W32F_SOURCE = "Win32File Object"

Private Enum enuDesiredAccess
   GENERIC_WRITE = &H40000000
   GENERIC_READ = &H80000000
   GENERIC_Default = GENERIC_READ Or GENERIC_WRITE
End Enum

Private Enum enuShareMode
   FILE_SHARE_READ = &H1
   FILE_SHARE_WRITE = &H2
End Enum

Private Enum enuFlagsAndAttributes
   FILE_ATTRIBUTE_ARCHIVE = &H20
   FILE_ATTRIBUTE_HIDDEN = &H2
   FILE_ATTRIBUTE_NORMAL = &H80
   FILE_ATTRIBUTE_READONLY = &H1
   FILE_ATTRIBUTE_SYSTEM = &H4
   FILE_ATTRIBUTE_TEMPORARY = &H100
   FILE_FLAG_OVERLAPPED = &H40000000
   FILE_FLAG_NO_BUFFERING = &H20000000
   FILE_FLAG_WRITE_THROUGH = &H80000000
   FILE_FLAG_RANDOM_ACCESS = &H10000000
   FILE_FLAG_SEQUENTIAL_SCAN = &H8000000
   FILE_FLAG_DELETE_ON_CLOSE = &H4000000
   FILE_FLAG_BACKUP_SEMANTICS = &H2000000
   FILE_FLAG_POSIX_SEMANTICS = &H1000000
End Enum

Private Enum enuFileSeekMove
   FILE_BEGIN = 0
   FILE_CURRENT = 1
   FILE_END = 2
End Enum

'Private Const GENERIC_WRITE = &H40000000
'Private Const GENERIC_READ = &H80000000
Private Const CREATE_ALWAYS = 2
Private Const OPEN_ALWAYS = 4
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Const ERROR_DEV_NOT_EXIST = 55

Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, 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 Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As enuFileSeekMove) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long

' Win2k
'Private Declare Function GetFileSizeEx Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Currency) As Long
Private Declare Function SetFilePointerEx Lib "kernel32" (ByVal hFile As Long, ByVal liDistanceToMove As Currency, lpNewFilePointer As Currency, ByVal dwMoveMethod As enuFileSeekMove) As Long

' 記憶體
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private hFile As Long, sFName As String, fAutoFlush As Boolean

' 磁碟空間
Private Type typLong64
   Low As Long
   High As Long
End Type

Private Const BufferLen = 256

Private Function CLong64(hLong64 As typLong64)
       
ReDim tBytes(1 To 16) As Byte
Dim tVar As Variant

CopyMemory tBytes(9), hLong64, Len(hLong64)
tBytes(1) = vbDecimal
CopyMemory tVar, tBytes(1), 16

CLong64 = tVar

End Function

Private Function CTypeLong64(ByVal hDecimal As Variant) As typLong64
       
ReDim tBytes(1 To 16) As Byte

hDecimal = CDec(hDecimal)

CopyMemory tBytes(1), hDecimal, 16
CopyMemory CTypeLong64, tBytes(9), 8

End Function

Public Property Get FileSize() As Variant

Dim tFileLen As typLong64

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
Else
' Win2k
'  FileSize = GetFileSizeEx(hFile, LongFileLen)
   tFileLen.Low = GetFileSize(hFile, tFileLen.High)
   
   FileSize = CLong64(tFileLen)
End If

End Property

Public Property Get FileHandle() As Long

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If
FileHandle = hFile

End Property

Public Property Get FileName() As String

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If
FileName = sFName

End Property

Public Property Get IsOpen() As Boolean

IsOpen = hFile <> INVALID_HANDLE_VALUE

End Property

Public Property Get AutoFlush() As Boolean

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If
AutoFlush = fAutoFlush

End Property

Public Property Let AutoFlush(ByVal NewVal As Boolean)

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If
fAutoFlush = NewVal

End Property

Public Sub OpenFile(ByVal sFileName As String, Optional ByVal dwFileAccess As enuFileAccess = Default)
  
If hFile <> INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_OPEN, sFName
End If

Select Case dwFileAccess
Case ReadOnly
   dwDesiredAccess = GENERIC_READ
   dwShareMode = FILE_SHARE_READ
   dwCreationDisposition = OPEN_EXISTING
   dwFlagsAndAttributes = FILE_ATTRIBUTE_NORMAL
Case Else
   dwDesiredAccess = GENERIC_Default
   dwShareMode = 0
   dwCreationDisposition = OPEN_ALWAYS
   dwFlagsAndAttributes = FILE_ATTRIBUTE_NORMAL
End Select

hFile = CreateFile(sFileName, dwDesiredAccess, dwShareMode, 0, dwCreationDisposition, dwFlagsAndAttributes, 0)

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_PROBLEM_OPENING_FILE, sFileName
End If
sFName = sFileName

End Sub

Public Sub CloseFile()
  
If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If
CloseHandle hFile
sFName = ""
fAutoFlush = False
hFile = INVALID_HANDLE_VALUE

End Sub

Public Function ReadBytes(ByVal ByteCount As Long) As Variant

Dim BytesRead As Long, Bytes() As Byte

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If

ReDim Bytes(0 To ByteCount - 1) As Byte

summy = ReadFile(hFile, Bytes(0), ByteCount, BytesRead, 0)

If summy = 0 Then
   ReadBytes = Err.LastDllError
Else
   ReadBytes = Bytes
End If

End Function

Public Sub WriteBytes(DataBytes() As Byte)

Dim fSuccess As Long, BytesToWrite As Long, BytesWritten As Long
  
If hFile = INVALID_HANDLE_VALUE Then
  RaiseError W32F_FILE_ALREADY_CLOSED
End If
BytesToWrite = UBound(DataBytes) - LBound(DataBytes) + 1
fSuccess = WriteFile(hFile, DataBytes(LBound(DataBytes)), BytesToWrite, BytesWritten, 0)
If fAutoFlush Then Flush

End Sub

Public Sub Flush()

If hFile = INVALID_HANDLE_VALUE Then
  RaiseError W32F_FILE_ALREADY_CLOSED
End If
FlushFileBuffers hFile

End Sub

Public Function SeekAbsolute(ByVal LowPos, Optional ByVal HighPos)

' 用 VB 的定位, Seek 基底為 1
Dim tFileLen As typLong64

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
Else
   LowPos = LowPos - 1
   
   If IsMissing(HighPos) Then
      tFileLen = CTypeLong64(LowPos)
' Win2k
'      summy = SetFilePointerEx(hFile, LowPos, tNewPointer, FILE_BEGIN)
'      SeekAbsolute = tNewPointer * 10000 + 1
   Else
      tFileLen.Low = LowPos
      tFileLen.High = HighPos
   End If
   
   tFileLen.Low = SetFilePointer(hFile, tFileLen.Low, tFileLen.High, FILE_BEGIN)
   
   SeekAbsolute = CLong64(tFileLen)
End If

End Function

Public Sub SeekRelative(ByVal Offset As Long)

Dim TempLow As Long, TempErr As Long
If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
End If
TempLow = SetFilePointer(hFile, Offset, ByVal 0&, FILE_CURRENT)
If TempLow = -1 Then
   TempErr = Err.LastDllError
   If TempErr Then
      RaiseError W32F_Problem_seeking, "Error " & TempErr & "." & vbNewLine & CStr(TempErr)
   End If
End If

End Sub

Public Function SetFileEnd()

Dim tNewPointer As Currency
Dim tFileLen As typLong64

If hFile = INVALID_HANDLE_VALUE Then
   RaiseError W32F_FILE_ALREADY_CLOSED
Else
   summy = SetEndOfFile(hFile)
   tFileLen.Low = SetFilePointer(hFile, tFileLen.Low, tFileLen.High, FILE_CURRENT)
   
   CopyMemory tNewPointer, tFileLen, Len(tFileLen)
   
' Win2k
'   summy = SetFilePointerEx(hFile, 0@, tNewPointer, FILE_CURRENT)
     
   SetFileEnd = tNewPointer * 10000 + 1
End If

End Function

Private Sub Class_Initialize()

hFile = INVALID_HANDLE_VALUE

End Sub

Private Sub Class_Terminate()

If hFile <> INVALID_HANDLE_VALUE Then CloseHandle hFile

End Sub

Private Sub RaiseError(ByVal ErrorCode As W32F_Errors, Optional sExtra)

Dim Win32Err As Long, Win32Text As String

Win32Err = Err.LastDllError

If Win32Err Then
   Win32Text = vbNewLine & "Error " & Win32Err & vbNewLine & DecodeAPIErrors(Win32Err)
End If

Select Case ErrorCode
Case W32F_FILE_ALREADY_OPEN
   Err.Raise W32F_FILE_ALREADY_OPEN, W32F_SOURCE, "檔案 '" & sExtra & "' 已經開啟." & Win32Text
Case W32F_PROBLEM_OPENING_FILE
   Err.Raise W32F_PROBLEM_OPENING_FILE, W32F_SOURCE, "開啟檔案錯誤 '" & sExtra & "'." & Win32Text
Case W32F_FILE_ALREADY_CLOSED
   Err.Raise W32F_FILE_ALREADY_CLOSED, W32F_SOURCE, "目前沒有開啟正在使用中的檔案."
Case W32F_Problem_seeking
   Err.Raise W32F_Problem_seeking, W32F_SOURCE, "Seek 錯誤." & vbNewLine & sExtra
Case W32F_Problem_Source_Close
   Err.Raise W32F_Problem_Source_Close, W32F_SOURCE, "來源端檔案關閉." & vbNewLine & Win32Text
Case Else
   Err.Raise W32F_UNKNOWN_ERROR, W32F_SOURCE, "未定義錯誤." & Win32Text
End Select

End Sub

Public Function DecodeAPIErrors(ByVal ErrorCode As Long) As String
Dim sMessage As String, MessageLength As Long

sMessage = String(BufferLen, 0)
MessageLength = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrorCode, 0&, sMessage, 256&, 0&)
If MessageLength > 0 Then
   DecodeAPIErrors = Left(sMessage, MessageLength)
Else
   DecodeAPIErrors = "Unknown Error."
End If

End Function