'===========================================================================
' Subject: TRUNCATE FILE                     Date: Unknown Date           
' Author:  Unknown Author(s)                 Code: QB, PDS                
' Origin:  FidoNet QUIK_BAS Echo           Packet: DOS.ABC
'===========================================================================
' > Is there an easy way in QB to truncate a file to a certain length
' > without copying it? 
 
'Sure .. Not directly via QB, but through an interrupt call. As long as
'the file is opened for RANDOM, BINARY or OUTPUT, this should work fine.
'I wrote it for QBX, but it'll work fine for other version by changing
'the $INCLUDE to QB.BI for VBDOS.BI.
 
    DECLARE FUNCTION TruncateFile% (Handle%, NewLength&)
    DEFINT A-Z
    REM $INCLUDE: 'qbx.bi'
    OPEN "TEST.DAT" FOR BINARY AS #1        'Create a file to test
    A$ = " "
    PUT #1, 10240, A$                       'Make it 10K long
    PRINT "File length:"; LOF(1)            'Make sure
    Handle% = FILEATTR(1, 2)                'Get DOS file handle
    NewLength& = 5000                       'New length for this file
    Status% = TruncateFile%(Handle%, NewLength&)    'Do it
    IF Status% THEN
        PRINT "DOS Error";Status%;" occurred."
    ELSE
        PRINT "New file length:"; LOF(1)
    END IF
    CLOSE
 
FUNCTION TruncateFile% (Handle%, NewLength&)
 
    DIM Reg AS RegTypeX
 
    'First, position the file read/write pointer to the place where the
    'truncation should take place. We can't trust BASIC's SEEK statement
    'because the movement is sometimes held until the next read/write.
 
    Reg.AX = &H4200             'DOS "Set file pointer" function
    Reg.BX = Handle%
 
    'We go through these steps to prevent "overflow" errors when
    'NewLength& > 32767. The high word of the file position goes in CX
    'and the low word goes in DX. Since BASIC treats integers and longs
    '"signed" variables, we need to take to extra steps to prevent
    'an overflow error as we break the long integer down.
 
    DEF SEG
    Addr% = VARPTR(NewLength&)
    Reg.CX = CVI(CHR$(PEEK(Addr% + 2)) + CHR$(PEEK(Addr% + 3)))
    Reg.DX = CVI(CHR$(PEEK(Addr%)) + CHR$(PEEK(Addr% + 1)))
    CALL InterruptX(&H21, Reg, Reg)
    IF Reg.Flags AND 1 THEN
        Status% = Reg.AX
        GOTO TruncateExit
    END IF
 
    'Now, write 0 bytes.
    Reg.AX = &H4000                 'Dos "Write file or device"
    Reg.BX = Handle%
    Reg.CX = 0                      'Write 0 bytes
    Reg.DX = 0                      'These are not needed, but make
    Reg.DS = 0                      ' sure they're zero, just in case
    CALL InterruptX(&H21, Reg, Reg)
    IF Reg.Flags AND 1 THEN
        Status% = Reg.AX
    END IF
 
TruncateExit:
    TruncateFile% = Status%
 
END FUNCTION