VB6 - Insert & Delete data from a file

[CVMichael]

It was asked in one of the threads (here) how to insert data into a file without loosing (overriding) any data, and also how to delete data from a file resulting in a smaller file size.

The theory is simple, when inserting data, you have to shift the data to the right from the position you plan to insert to, and insert the actual data to that position and for deleting, you have to shift the data to the left until the position of deletion, and then truncate the file.

Here's an example how to insert data:

Option Explicit
 
Private Sub Form_Load()
    Dim FF As Integer
    
    ' Create some file as an example for testing...
    FF = FreeFile
    Open "C:\test_insert.txt" For Binary Access Read Write As FF
    Put FF, , "01234567890123456789012345678901234567890123456789012345678901234567890123456789"
    Close FF
    
    
    
    FF = FreeFile
    Open "C:\test_insert.txt" For Binary Access Read Write As FF
    
    ' insert some data into the file
    InsertData FF, "+-----+", 3
    
    Close FF
End Sub
 
Private Sub InsertData(ByVal FileNum As Integer, DataToInsert As String, ByVal InsertPos As Long)
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=433537[/url]
    '
 
    Const cBuffSize As Long = 262144 ' 256 KBytes
    
    Dim Buffer() As Byte, BuffPos As Long
    
    ' Shift all data to the right
    
    If LOF(FileNum) - InsertPos < cBuffSize Then
        ' we can do it in one copy, we don't need a loop
        
        ' resize the buffer so we don't copy too much (more than file size)
        ReDim Buffer(LOF(FileNum) - InsertPos - 1)
        
        ' copy and paste the data to the new location
        Get FileNum, InsertPos, Buffer
        Put FileNum, InsertPos + Len(DataToInsert), Buffer
    Else
        ' we start from the end of the file
        BuffPos = LOF(FileNum)
        
        ' we HAVE to shift from right to left,
        ' otherwise we override important data
        
        Do Until BuffPos <= InsertPos
            ' substract the buffer size from current position
            BuffPos = BuffPos - cBuffSize
            
            If BuffPos < InsertPos Then
                ' we reached the last copy
                ' data passed the InsertPos position, so we have to
                ' resize the buffer so it does not go over InsertPos
                
                ReDim Buffer(cBuffSize - (InsertPos - BuffPos) - 1)
                BuffPos = InsertPos
            Else
                ReDim Buffer(cBuffSize - 1)
            End If
            
            ' copy and paste the data to the new location
            Get FileNum, BuffPos, Buffer
            Put FileNum, BuffPos + Len(DataToInsert), Buffer
        Loop
    End If
    
    ' Insert the actual data
    Put FileNum, InsertPos, DataToInsert
End Sub

And here is an example on how to delete data:

Option Explicit
 
Private Const GENERIC_READ_WRITE As Long = &HC0000000
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const FILE_BEGIN As Long = 0
Private Const NO_ERROR As Long = 0
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _ 
     ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _ 
     ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, _ 
     ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _ 
     ByVal hTemplateFile 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 SetFilePointer Lib "kernel32" ( _ 
     ByVal hFile As Long, ByVal lDistanceToMove As Long, _ 
     lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
 
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, _ 
     lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _ 
     lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, _ 
     lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, _ 
     lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
 
Private Declare Function GetLastError Lib "kernel32" () As Long
 
 
Private Sub DeleteData(ByVal FileName As String, DeletePos As Long, DeleteLength As Long)
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=433537[/url]
    '
    Const cBuffSize As Long = 262144 ' 256 KBytes
    
    Dim SA As SECURITY_ATTRIBUTES
    Dim FHandle As Long
    Dim FileLen As Double
    Dim Buffer() As Byte, BuffPtr As Long
    
    Dim BytesToRead As Long, BytesRead As Long
    Dim ReadPos As Double, WritePos As Double
    
    ' using API position 0 is the first byte, using VB functions position 1 is first byte
    ' so decrement by one to use the same standard...
    DeletePos = DeletePos - 1
    
    ' open the file
    FHandle = CreateFile(FileName, GENERIC_READ_WRITE, 0, SA, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
    
    ' get file size
    FileLen = FileSizeDouble(FHandle)
    
    ' alocate memory
    ReDim Buffer(cBuffSize - 1)
    
    ' get memory pointer
    BuffPtr = VarPtr(Buffer(0))
    
    ' calculate read & write positions
    WritePos = DeletePos
    ReadPos = WritePos + DeleteLength
    
    ' shift the data to left
    
    Do Until ReadPos >= FileLen
        ' calculate how much data to read/write
        BytesToRead = dblMIN(cBuffSize, FileLen - ReadPos)
        
        ' copy and paste the data to the new location
        SeekPosDouble FHandle, ReadPos
        ReadFile FHandle, ByVal BuffPtr, BytesToRead, BytesRead, ByVal 0&
        
        SeekPosDouble FHandle, WritePos
        WriteFile FHandle, ByVal BuffPtr, BytesRead, BytesRead, ByVal 0&
        
        WritePos = WritePos + BytesRead
        ReadPos = WritePos + DeleteLength
    Loop
    
    If WritePos < FileLen Then
        ' Seek to where we need to truncate the file
        SeekPosDouble FHandle, WritePos
        
        ' truncate the file
        SetEndOfFile FHandle
    End If
    
    Erase Buffer
    If FHandle <> 0 Then CloseHandle FHandle
End Sub
 
Private Function dblMIN(ByVal V1 As Double, ByVal V2 As Double) As Double
    If V1 < V2 Then
        dblMIN = V1
    Else
        dblMIN = V2
    End If
End Function
 
Private Function SeekPosDouble(ByVal FHandle As Long, ByVal NewPos As Double) As Boolean
    Dim SizeLow As Long, SizeHigh As Long
    
    SizeLow = DoubleToLongs(NewPos, SizeHigh)
    
    SeekPosDouble = SeekPos(FHandle, SizeLow, SizeHigh)
End Function
 
Private Function SeekPos(ByVal FHandle As Long, ByVal NewPos As Long, _
                                   Optional ByVal PosHigh As Long = 0) As Boolean
    Dim Ret As Long, dwError As Long
    
    Ret = SetFilePointer(FHandle, NewPos, PosHigh, FILE_BEGIN)
    
    If Ret = -1 Then
        dwError = GetLastError
        If dwError = NO_ERROR Then SeekPos = True
    Else
        SeekPos = True
    End If
End Function
 
Private Function FileSizeDouble(ByVal FHandle As Long) As Double
    Dim SizeLow As Long, SizeHigh As Long
    
    If FHandle <> 0 Then SizeLow = GetFileSize(FHandle, SizeHigh)
    
    FileSizeDouble = CDbl(SizeHigh) * (2 ^ 32) + LongToDouble(SizeLow)
End Function
 
Private Function LongToDouble(ByVal Lng As Long) As Double
    If Lng And &H80000000 = 0 Then
        LongToDouble = CDbl(Lng)
    Else
        LongToDouble = (Lng Xor &H80000000) + (2 ^ 31)
    End If
End Function
 
Private Function DoubleToLongs(ByVal Dbl As Double, ByRef SizeHigh As Long) As Long
    Dim SizeLowDbl As Double
    
    SizeHigh = Fix(Dbl / 4294967296#)
    SizeLowDbl = Dbl - SizeHigh * 4294967296#
    
    If SizeLowDbl > 2147483647 Then
        DoubleToLongs = CLng(SizeLowDbl - 2147483648#) Xor &H80000000
    Else
        DoubleToLongs = SizeLowDbl
    End If
End Function
 
Private Sub Form_Load()
    Dim FF As Integer
    
    ' Create some file as an example for testing...
    FF = FreeFile
    Open "C:\test_delete.txt" For Binary Access Read Write As FF
    Put FF, , "01234567890123456789012345678901234567890123456789012345678901234567890123456789"
    Close FF
    
    ' delete 2 bytes from the 3'rd position
    ' it should decrease the file size by 2 bytes
    DeleteData "C:\test_delete.txt", 3, 2
End Sub

Since I have to use API to truncate the file, I decided to write the whole thing in API...