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 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 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 String, ByVal 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]