Attribute VB_Name = "FileAPIs"
Option Explicit

Private Type KsUdtAdrWords
  lWord As Long
  hWord As Long
End Type

Private Type KsUdtAdrCurr
  Adress As Currency
End Type

Public Const OPEN_EXISTING                     As Long = 3
Public Const GENERIC_WRITE                     As Long = &H40000000
Public Const GENERIC_READ                      As Long = &H80000000
Public Const OPEN_ALWAYS                       As Long = 4
Public Const FILE_SHARE_READ                   As Long = &H1
Public Const FILE_SHARE_WRITE                  As Long = &H2
Public Const INVALID_HANDLE_VALUE = -1

Public Const FORMAT_MESSAGE_FROM_SYSTEM        As Long = &H1000
Public Const ERROR_ALREADY_EXISTS              As Long = 183&
Public Const FILE_BEGIN                        As Long = 0
Public Const FILE_CURRENT                      As Long = 1
Public Const FILE_END                          As Long = 2


Public 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
Public Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Public Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Public Declare Function SetFilePointerOld Lib "kernel32" Alias "SetFilePointer" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Public Declare Function SetFilePointerEx Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Currency, lpNewFilePointer As Currency, ByVal dwMoveMethod As Long) As Long

Public Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
                                                    ByVal dwFlags As Long _
                                                    , lpSource As Any _
                                                    , ByVal dwMessageId As Long _
                                                    , ByVal dwLanguageId As Long _
                                                    , ByVal lpBuffer As String _
                                                    , ByVal nSize As Long _
                                                    , Arguments As Long _
                                                    ) As Long

Public Function extGetFileSize(FileName As String) As Currency
  Dim OFileNumb As Long
  Dim retValLo As Long
  Dim retValHi As Long
  
  OFileNumb = CreateFile(FileName, 0, 0, 0, OPEN_EXISTING, 0, 0)
  If OFileNumb > 0 Then
    retValLo = GetFileSize(OFileNumb, retValHi)
    extGetFileSize = mFWords2Adr(retValLo, retValHi) * 10000
    CloseHandle OFileNumb
  End If
End Function

Public Function extSetFilePointer(FileNum As Long, FilePos As Currency) As Boolean
  Dim RetValHelper As Long

  If IsNt Then
    extSetFilePointer = SetFilePointerEx(FileNum, FilePos / 10000, 0, FILE_BEGIN) <> 0
  Else
    If FilePos < 2147483648# Then
      SetFilePointerOld FileNum, CLng(FilePos), RetValHelper, FILE_BEGIN
      extSetFilePointer = RetValHelper = 0
    End If
  End If
End Function

Private Function mFWords2Adr(ByVal xLngLowWord As Long, ByVal xLngHeightWord As Long) As Currency
  Dim pvUdtAdr As KsUdtAdrCurr
  Dim pvUdtWrd As KsUdtAdrWords
  
  pvUdtWrd.lWord = xLngLowWord
  pvUdtWrd.hWord = xLngHeightWord
  
  LSet pvUdtAdr = pvUdtWrd
  mFWords2Adr = pvUdtAdr.Adress
End Function

Private Function mFAdr2Words(ByVal xCurAdress As Currency) As KsUdtAdrWords
  Dim pvUdtAdr As KsUdtAdrCurr
  Dim pvUdtWrd As KsUdtAdrWords
  
  pvUdtAdr.Adress = xCurAdress
  LSet pvUdtWrd = pvUdtAdr
  mFAdr2Words = pvUdtWrd
End Function

Public Function mFGetApiErrMsg(ByVal xLngErrNr As Long) As String
  Dim pvLngLen As Long
  Dim pvStrBuffer As String
  
  pvStrBuffer = Space(256)
  pvLngLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, xLngErrNr, 0, pvStrBuffer, Len(pvStrBuffer), ByVal 0)
  mFGetApiErrMsg = Left$(pvStrBuffer, pvLngLen)
End Function

