Wednesday, June 30, 2021

Russian 3D Jet simulator in Visual Basic 6.0

Links on VBForums start to disappear in time as they are replaced with more and more complex implementations in VB6. What I do here is to preserve what Mikle uploaded on Yandex. If you wish to build a professional 3D game in VB6, with Mikle's implementations the sky's the limit !

Download from ME










Wednesday, June 9, 2021

Gigabyte file read/write: Binary I/O on very large disk files


Download from ME

Option Explicit
'
'HugeBinaryFile
'==============
'
'A class for doing simple binary I/O on very large disk files
'(well over the usual 2GB limit).  It only does I/O using Byte
'arrays, and makes use of Currency values that are scaled to
'whole numbers in places:
'
'   For a file of one byte the FileLen property returns 1.0000 as
'   its value.
'
'Operation is similar in many ways to native VB Get#/Put# I/O, for
'example the EOF property must be checked after a ReadBytes() call.
'You must also Dim/Redim buffers to desired sizes before calling
'ReadBytes() or WriteBytes().
'
'Short (signed Long) relative seeks and long (unsigned Currency)
'absolute seeks from 0 may be done.
'
'AutoFlush may be set True to force buffer flushes on every write.
'The Flush() method may be called explicitly if necessary.
'

Public Enum HBF_Errors
  HBF_UNKNOWN_ERROR = 45600
  HBF_FILE_ALREADY_OPEN
  HBF_OPEN_FAILURE
  HBF_SEEK_FAILURE
  HBF_FILELEN_FAILURE
  HBF_READ_FAILURE
  HBF_WRITE_FAILURE
  HBF_FILE_ALREADY_CLOSED
End Enum

Private Const HBF_SOURCE = "HugeBinaryFile"

Private Const GENERIC_WRITE As Long = &H40000000
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80&
Private Const CREATE_ALWAYS = 2
Private Const OPEN_ALWAYS = 4
Private Const INVALID_HANDLE_VALUE = -1
Private Const INVALID_SET_FILE_POINTER = -1
Private Const INVALID_FILE_SIZE = -1

Private Const FILE_BEGIN = 0, FILE_CURRENT = 1, FILE_END = 2

Private Type MungeCurr
    Value As Currency
End Type

Private Type Munge2Long
    LowVal As Long
    HighVal As Long
End Type

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 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 CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long

Private Declare Function GetFileSize Lib "kernel32" ( _
    ByVal hFile As Long, _
    lpFileSizeHigh As Long) 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

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 SetFilePointer Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lDistanceToMove As Long, _
    lpDistanceToMoveHigh As Long, _
    ByVal dwMoveMethod As Long) As Long

Private Declare Function FlushFileBuffers Lib "kernel32" ( _
    ByVal hFile As Long) As Long

Private hFile As Long
Private sFName As String
Private fAutoFlush As Boolean
Private fEOF As Boolean
Private C As MungeCurr
Private L As Munge2Long

Public Property Get AutoFlush() As Boolean
    RaiseErrorIfClosed
    AutoFlush = fAutoFlush
End Property

Public Property Let AutoFlush(ByVal NewVal As Boolean)
    RaiseErrorIfClosed
    fAutoFlush = NewVal
End Property

Public Property Get FileHandle() As Long
    RaiseErrorIfClosed
    FileHandle = hFile
End Property

Public Property Get FileLen() As Currency
    RaiseErrorIfClosed
    L.LowVal = GetFileSize(hFile, L.HighVal)
    If L.LowVal = INVALID_FILE_SIZE Then
        If Err.LastDllError Then RaiseError HBF_FILELEN_FAILURE
    End If
    LSet C = L
    FileLen = C.Value * 10000@
End Property

Public Property Get FileName() As String
    RaiseErrorIfClosed
    FileName = sFName
End Property

Public Property Get EOF() As Boolean
    RaiseErrorIfClosed
    EOF = fEOF
End Property

Public Property Get IsOpen() As Boolean
    IsOpen = hFile <> INVALID_HANDLE_VALUE
End Property

Public Sub CloseFile()
    RaiseErrorIfClosed
    CloseHandle hFile
    sFName = ""
    fAutoFlush = False
    fEOF = False
    hFile = INVALID_HANDLE_VALUE
End Sub

Public Sub Flush()
    RaiseErrorIfClosed
    FlushFileBuffers hFile
End Sub

Public Sub OpenFile(ByVal OpenFileName As String)
    If hFile <> INVALID_HANDLE_VALUE Then
        RaiseError HBF_FILE_ALREADY_OPEN
    End If
    hFile = CreateFile(OpenFileName, GENERIC_WRITE Or GENERIC_READ, 0, _
                       0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = INVALID_HANDLE_VALUE Then
        RaiseError HBF_OPEN_FAILURE
    End If
    sFName = OpenFileName
End Sub

Public Function ReadBytes(ByRef Buffer() As Byte) As Long
    RaiseErrorIfClosed
    If ReadFile(hFile, _
                Buffer(LBound(Buffer)), _
                UBound(Buffer) - LBound(Buffer) + 1, _
                ReadBytes, _
                0) Then
        If ReadBytes = 0 Then
            fEOF = True
        End If
    Else
        RaiseError HBF_READ_FAILURE
    End If
End Function

Public Sub SeekAbsolute(ByVal Position As Currency)
    RaiseErrorIfClosed
    C.Value = Position / 10000@
    LSet L = C
    If SetFilePointer(hFile, L.LowVal, L.HighVal, FILE_BEGIN) _
        = INVALID_SET_FILE_POINTER Then
            If Err.LastDllError Then RaiseError HBF_SEEK_FAILURE
    End If
End Sub

Public Sub SeekEnd()
    RaiseErrorIfClosed
    If SetFilePointer(hFile, 0&, ByVal 0&, FILE_END) _
        = INVALID_SET_FILE_POINTER Then
            RaiseError HBF_SEEK_FAILURE
    End If
End Sub

Public Sub SeekRelative(ByVal Offset As Long)
    'Offset is signed.
    RaiseErrorIfClosed
    If SetFilePointer(hFile, Offset, ByVal 0&, FILE_CURRENT) _
        = INVALID_SET_FILE_POINTER Then
            RaiseError HBF_SEEK_FAILURE
    End If
End Sub

Public Function WriteBytes(Buffer() As Byte) As Long
    RaiseErrorIfClosed
    If WriteFile(hFile, _
                 Buffer(LBound(Buffer)), _
                 UBound(Buffer) - LBound(Buffer) + 1, _
                 WriteBytes, _
                 0) Then
        If fAutoFlush Then Flush
    Else
        RaiseError HBF_WRITE_FAILURE
    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 HBF_Errors)
    Dim Win32Err As Long, Win32Text As String

    Win32Err = Err.LastDllError
    If Win32Err Then
        Win32Text = vbNewLine & "Error " & Win32Err & vbNewLine _
                  & DecodeAPIErrors(Win32Err)
    End If
    If IsOpen Then CloseFile
    Select Case ErrorCode
        Case HBF_FILE_ALREADY_OPEN
            Err.Raise HBF_FILE_ALREADY_OPEN, HBF_SOURCE, _
                "File already open."
        Case HBF_OPEN_FAILURE
            Err.Raise HBF_OPEN_FAILURE, HBF_SOURCE, _
                "Error opening file." & Win32Text
        Case HBF_SEEK_FAILURE
            Err.Raise HBF_SEEK_FAILURE, HBF_SOURCE, _
                "Seek Error." & Win32Text
        Case HBF_FILELEN_FAILURE
            Err.Raise HBF_FILELEN_FAILURE, HBF_SOURCE, _
                "GetFileSize Error." & Win32Text
        Case HBF_READ_FAILURE
            Err.Raise HBF_READ_FAILURE, HBF_SOURCE, _
                "Read failure." & Win32Text
        Case HBF_WRITE_FAILURE
            Err.Raise HBF_WRITE_FAILURE, HBF_SOURCE, _
                "Write failure." & Win32Text
        Case HBF_FILE_ALREADY_CLOSED
            Err.Raise HBF_FILE_ALREADY_CLOSED, HBF_SOURCE, _
                "File must be open for this operation."
        Case Else
            Err.Raise HBF_UNKNOWN_ERROR, HBF_SOURCE, _
               "Unknown error." & Win32Text
    End Select
End Sub

Private Sub RaiseErrorIfClosed()
    If hFile = INVALID_HANDLE_VALUE Then RaiseError HBF_FILE_ALREADY_CLOSED
End Sub

Private Function DecodeAPIErrors(ByVal ErrorCode As Long) As String
    Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000&
    Dim strMsg As String, lngMsgLen As Long

    strMsg = Space$(256)
    lngMsgLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, _
                              ErrorCode, 0&, strMsg, 256&, 0&)
    If lngMsgLen > 0 Then
        DecodeAPIErrors = Left(strMsg, lngMsgLen)
    Else
        DecodeAPIErrors = "Unknown Error."
    End If
End Function


Option Explicit
'
'Timer-driven demo of HugeBinaryFile class.
'

Private hbfFile As HugeBinaryFile
Private blnWriting As Boolean
Private bytBuf(1 To 1000000) As Byte
Private lngBlocks As Long
Private Const MAX_BLOCKS As Long = 5000

Private Sub cmdRead_Click()
    cmdWrite.Enabled = False
    cmdRead.Enabled = False
    lngBlocks = 0
    lblRead.Caption = ""
    blnWriting = False
    Set hbfFile = New HugeBinaryFile
    hbfFile.OpenFile "test.dat"
    lblStatus = " Reading " _
              & Format$(hbfFile.FileLen, "##,###,###,###,##0") _
              & " bytes"
    Timer1.Enabled = True
End Sub

Private Sub cmdWrite_Click()
    cmdWrite.Enabled = False
    cmdRead.Enabled = False
    On Error Resume Next
    Kill "test.dat"
    On Error GoTo 0
    lngBlocks = 0
    lblWritten.Caption = ""
    lblStatus = " Writing " _
              & Format$(CCur(MAX_BLOCKS) * CCur(UBound(bytBuf)), "##,###,###,###,##0") _
              & " bytes"
    blnWriting = True
    Set hbfFile = New HugeBinaryFile
    hbfFile.OpenFile "test.dat"
    Timer1.Enabled = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Not (hbfFile Is Nothing) Then
        If hbfFile.IsOpen Then hbfFile.CloseFile
        Set hbfFile = Nothing
    End If
End Sub

Private Sub Timer1_Timer()
    If blnWriting Then
        hbfFile.WriteBytes bytBuf
        lngBlocks = lngBlocks + 1
        lblWritten.Caption = _
                Format$(CCur(lngBlocks) * CCur(UBound(bytBuf)), "##,###,###,###,##0") _
              & " bytes written"
        If lngBlocks >= MAX_BLOCKS Then
            Timer1.Enabled = False
            hbfFile.CloseFile
            Set hbfFile = Nothing
            lblStatus = ""
            cmdWrite.Enabled = True
            cmdRead.Enabled = True
        End If
    Else
        hbfFile.ReadBytes bytBuf
        If hbfFile.EOF Then
            Timer1.Enabled = False
            hbfFile.CloseFile
            Set hbfFile = Nothing
            lblStatus = ""
            cmdWrite.Enabled = True
            cmdRead.Enabled = True
        Else
            lngBlocks = lngBlocks + 1
            lblRead.Caption = _
                    Format$(CCur(lngBlocks) * CCur(UBound(bytBuf)), "##,###,###,###,##0") _
                  & " bytes read"
        End If
    End If
End Sub