GFShrinkFile/GFShrinkFile.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4710
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4710
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Shrink!"
      Height          =   375
      Left            =   2640
      TabIndex        =   0
      Top             =   180
      Width           =   1935
   End
   Begin VB.TextBox Text1
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Text            =   "c:\test.dat"
      Top             =   240
      Width           =   2355
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2000, 2004 by Louis. Use to shrink a large file without copying it.
'
'Downloaded from www.louis‑coder.com.
'Shrinks a file without copying.
'
'GFShrinkFile
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As LongByVal lDistanceToMove As Long, lpDistanceToMoveHigh As LongByVal dwMoveMethod As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'GFShrinkFile
Private Const OFS_MAXPATHNAME = 128
Private Const OF_READWRITE = &H2
Private Const FILE_BEGIN = 0
'GFShrinkFile
Private Type OFSTRUCT
    cBytes As Byte
    fFixedDisk As Byte
    nErrCode As Integer
    Reserved1 As Integer
    Reserved2 As Integer
    szPathName(OFS_MAXPATHNAME) As Byte
End Type

Private Sub Command1_Click()
    'on error resume next 'testing sub
    Open Text1.Text For Output As #1
        Print #1, String$(2000, Chr$(32));
    Close #1
    Debug.Print FileLen(Text1.Text)
    Debug.Print GFShrinkFile(Text1.Text, 1978)
    Debug.Print FileLen(Text1.Text)
    'Kill Text1.Text
End Sub

Private Function GFShrinkFile(ByVal ShrinkName As StringByVal ShrinkNameSizeNew As Long) As Boolean
    'on error resume next 'shrinks a file; function returns True if file was shrunk, False if not
    Dim ShrinkNameHandle As Long
    Dim OFSTRUCTVar As OFSTRUCT
    Dim ShrinkFileTemp As Long
    'verify
    If ((Dir(ShrinkName) = "") Or (Right$(ShrinkName, 1) = "\") Or (ShrinkName = "")) Then 'verify
        GFShrinkFile = False 'error
        Exit Function
    End If
    Select Case ShrinkNameSizeNew
    Case Is < 0
        GoTo Error:
    Case Is > FileLen(ShrinkName)
        ShrinkNameSizeNew = FileLen(ShrinkName)
    End Select
    'begin
    ShrinkNameHandle = OpenFile(ShrinkName, OFSTRUCTVar, OF_READWRITE)
    If ShrinkNameHandle = 0 Then GoTo Error: 'verify
    ShrinkFileTemp = SetFilePointer(ShrinkNameHandle, ShrinkNameSizeNew, 0, FILE_BEGIN)
    'If ShrinkFileTemp = 0 Then GoTo Error: 'functions returns something nobody understands
    ShrinkFileTemp = SetEndOfFile(ShrinkNameHandle)
    If ShrinkFileTemp = 0 Then GoTo Error: 'verify
    ShrinkFileTemp = CloseHandle(ShrinkNameHandle)
    If ShrinkFileTemp = 0 Then GoTo Error: 'verify
    GFShrinkFile = True 'ok
    Exit Function
Error:
    Call CloseHandle(ShrinkNameHandle) 'make sure file is closed
    GFShrinkFile = False 'error
    Exit Function
End Function


[END OF FILE]