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