Option Explicit

'32Bits version to truncate files.
'By E.B. Knoppert ProFinance Software
'Netherlands profinance@wxs.nl

Const OF_READWRITE = &H2
Const OF_SHARE_EXCLUSIVE = &H10
Const OFS_MAXPATHNAME = 260
Const FILE_BEGIN = 0

Public Type OFSTRUCT
        cBytes As Byte
        fFixedDisk As Byte
        nErrCode As Integer
        Reserved1 As Integer
        Reserved2 As Integer
        szPathName(OFS_MAXPATHNAME) As Byte
End Type

Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Public Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Public Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long

'OFSTRUCT Error Codes
'
'Value in Hexadecimal
'   Description
'1  Invalid function.
'2  File not found.
'3  Path not found.
'4  No file handle available.
'5  Access denied.
'6  Handle is invalid.
'7  DOS memory corrupted.
'8  Insufficient memory for the operation.
'9  Invalid block.
'A  Illegal environment.
'B  Invalid format.
'C  Invalid access.
'D  Invalid data.
'F  Invalid drive.
'10 Invalid current directory.
'11 Device is different.
'12 No more files.
'13 Write protect error.
'14 Illegal unit.
'15 Drive not ready.
'16 Invalid command.
'17 CRC validation error.
'18 Invalid length.
'19 Seek error.
'1A Disk is not MS-DOS compatible.
'1B Sector not found.
'1C Out of paper.
'1D Write fault.
'1E Read fault.
'1F General failure of the drive.
'20 Sharing violation.
'21 File lock violation.
'22 Incorrect disk.
'23 No file control block available.
'24 Sharing buffer exceeded.
'32 Device not supported.
'33 Remote device unavailable.
'34 Duplicate name.
'35 Bad network path.
'36 Network is busy.
'37 Illegal device.
'38 Too many commands.
'39 Hardware error on the network adapter.
'3A Network response error.
'3B Other network error.
'3C Remote adapter error.
'3D Full print queue.
'3E Print spooler full.
'3F Print canceled.
'40 Deleted netname.
'41 Network access denied.
'42 Invalid device type.
'43 Invalid network name.
'44 Too many names.
'45 Too many sessions.
'46 Sharing paused.
'47 Request not accepted.
'48 Redirection paused.
'50 File exists.
'51 Duplicate file control block.
'52 Cannot make.
'53 Interrupt 24 failure.
'54 Out of structures.
'55 Already assigned.
'56 Invalid password.
'57 Invalid parameter.
'58 Network write fault.

Sub Main()

    Dim SFLError As Integer
    
    Const DestinationFile = "c:\lentest.txt"

    Stop 'Look below before continue!
    
    'Create testfile..
    FileCopy "c:\autoexec.bat", DestinationFile
    
    'Set filelength (10 bytes)
    SFLError = TruncateFile(DestinationFile, 10)
    
    'Error? (See error codes in (general))
    If SFLError > 0 Then
    
        MsgBox "SetFileLength error ocurred!" & vbCrLf & SFLError & ", " & Error$(SFLError)
    
    Else

        MsgBox "SetFileLength succesfull" & vbCrLf & FileLen(DestinationFile) & " Bytes."
    
    End If

End Sub

Public Function TruncateFile(FileName As String, TruncateLength As Long) As Integer
      
    On Error Resume Next
    
    Dim FH              As Long
    Dim FP              As Long
    Dim lpReOpenBuff    As OFSTRUCT
    
    FH = OpenFile(FileName, lpReOpenBuff, OF_READWRITE Or OF_SHARE_EXCLUSIVE)
    Debug.Print "FH " & FH
        
    If FH > 0 Then

        'If valid filehandle, set filepointer (Like Seek)
        FP = SetFilePointer(FH, TruncateLength, ByVal 0&, FILE_BEGIN)
        
        'If filepointer is the given value truncate.
        If FP = TruncateLength Then SetEndOfFile FH

    End If

    TruncateFile = lpReOpenBuff.nErrCode

    CloseHandle FH

End Function
