FormShrink

Public Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Public Declare Function CreateRectRgn Lib "gdi32" _
(ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, _
ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" _
(ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) _
As Long
Public Declare Function SetWindowRgn Lib "user32" _
(ByVal hwnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Public Const RGN_OR = 2

Public Sub ShrinkForm(fForm As Form, iSleepTime As Long, _
Optional bRestoreAfter As Boolean = False)
Dim NewRegion As Long
Dim iX As Long, iY As Long
Dim iWidth As Long, iHeight As Long
'Get the form's size in pixels

iWidth = fForm.Width / Screen.TwipsPerPixelX
iHeight = fForm.Height / Screen.TwipsPerPixelY
'Check if form's height is larger

If iWidth < iHeight Then
'Shrink using the X coordinates

For iX = 0 To Int(iWidth / 2)
'Calculate Y value

iY = Int(iWidth / iHeight * iX)
'Create the region to show

NewRegion = CreateRectRgn(iX, iY, iWidth - iX, iHeight - iY)
'Show only the set region

Call SetWindowRgn(fForm.hwnd, NewRegion, True)
'Call DoEvents to allow the form to repaint

DoEvents
'Wait x milliseconds

Sleep iSleepTime
Next iX

Else

'Shrink using the Y coordinates

For iY = 0 To Int(iHeight / 2)
'Calculate X value

iX = Int(iHeight / iWidth * iY)
'Create the region to show

NewRegion = CreateRectRgn(iX, iY, iWidth - iX, iHeight - iY)
'Show only the set region

Call SetWindowRgn(fForm.hwnd, NewRegion, True)
'Call DoEvents to allow the form to repaint

DoEvents
'Wait x milliseconds

Sleep iSleepTime
Next iY
End If
'Check if form should be restored afterwards


If bRestoreAfter Then
NewRegion = CreateRectRgn(0, 0, iWidth, iHeight)
Call SetWindowRgn(fForm.hwnd, NewRegion, True)
End If
'Clear the region

DeleteObject NewRegion

End Sub