Minimum form-size 2

[bascy]

A few days ago I stumbled somewhere the net on a method of preventing users to resize a form below a certain minimum width and height. This method looked a lot better than the normal method of restoring the Height and Width to their minimum values in the Resize event, because this latter method shows an ugly line when the user hold the mousebutton.

Can anybody help me re-finding this?? I'v been surfing half the day but can't find it anymore!!!

thanks
bascy

 

[scorpio66]

It can be done, but you need to use the API for this.

Try the following. In your form:

Private Const C_MIN_WIDTH = 600
Private Const C_MIN_HEIGHT = 400

Private Sub Form_Load()
Hook Me.hWnd, C_MIN_WIDTH, C_MIN_HEIGHT
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unhook Me.hWnd
End Sub

Then add Resize.bas to your project

'----------------

Option Explicit

Public Type POINTAPI
x As Long
y As Long
End Type

Public Type MINMAXINFO
ptReserved As POINTAPI
ptMaxSize As POINTAPI
ptMaxPosition As POINTAPI
ptMinTrackSize As POINTAPI
ptMaxTrackSize As POINTAPI
End Type

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Const WU_LOGPIXELSX = 88
Const WU_LOGPIXELSY = 90

Public Const GWL_WNDPROC = -4

Private Windows As Collection

' Windows Messages
' Look them up in the API Text Viewer. All Windows Messages are Constants and starts with WM_
Public Const WM_GETMINMAXINFO = &H24
'
Public Sub Hook(hWnd As Long, minWidth As Integer, minHeight As Integer)
Dim SubClass As SubClassInfo

If Windows Is Nothing Then Set Windows = New Collection

On Error Resume Next
Set SubClass = Windows("sc" & hWnd)
If Err Then
Err.Clear

Set SubClass = New SubClassInfo
With SubClass
.hWnd = hWnd
.minWidth = minWidth
.minHeight = minHeight
.lpPrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End With

Windows.Add SubClass, "sc" & hWnd
End If
End Sub

Public Sub Unhook(hWnd)
Dim temp As Long
Dim SubClass As SubClassInfo

On Error Resume Next
Set SubClass = Windows("sc" & hWnd)
If Err = 0 Then
temp = SetWindowLong(hWnd, GWL_WNDPROC, SubClass.lpPrevWndProc)
Windows.Remove "sc" & hWnd
Else
Err.Clear
End If
End Sub

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim minWidth As Integer
Dim minHeight As Integer
Dim SubClass As SubClassInfo

On Error Resume Next
Set SubClass = Windows("sc" & hw)
If Err = 0 Then
minWidth = SubClass.minWidth
minHeight = SubClass.minHeight

Select Case uMsg
Case WM_GETMINMAXINFO
Dim mmiT As MINMAXINFO

' Copy the parameter lParam to a local variable so that we can play around with it
CopyMemory mmiT, ByVal lParam, Len(mmiT)

' Minimium width and height. The API works with pixels instead of twips :-(.
mmiT.ptMinTrackSize.x = minWidth
mmiT.ptMinTrackSize.y = minHeight

' Copy modified results back to parameter
CopyMemory ByVal lParam, mmiT, Len(mmiT)

' In this case we don't want VB to handle resizing.
' We will exit the function without sending the message to VB, forcing the API to deal with it.

Exit Function

End Select

WindowProc = CallWindowProc(SubClass.lpPrevWndProc, hw, uMsg, wParam, lParam)
Else
Err.Clear

' Don't know what to do here - I'm assuming that it is impossible for this
' situation to occur (a custom WindowProc running for an unsubclassed window).
End If
End Function

Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long

'Handle to device
Dim lngDC As Long
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440
lngDC = GetDC(0)

If (lngDirection = 0) Then 'Horizontal
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
Else 'Vertical
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
End If
lngDC = ReleaseDC(0, lngDC)
ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch

End Function

'----------------

Finally, we need a class (which I've called SubclassInfo to store some information about each form which has been subclassed.

'----------------

Option Explicit

Private Type SubClassInfo
hWnd As Long
minWidth As Integer
minHeight As Integer
lpPrevWndProc As Long
End Type

Private SubClassInfo As SubClassInfo

Private Sub Class_Initialize()
hWnd = 0
minWidth = 0
minHeight = 0
lpPrevWndProc = 0
End Sub

Public Property Get hWnd() As Long
hWnd = SubClassInfo.hWnd
End Property

Public Property Let hWnd(ByVal hWnd As Long)
SubClassInfo.hWnd = hWnd
End Property

Public Property Get minWidth() As Integer
minWidth = SubClassInfo.minWidth
End Property

Public Property Let minWidth(minWidth As Integer)
SubClassInfo.minWidth = minWidth
End Property

Public Property Get minHeight() As Integer
minHeight = SubClassInfo.minHeight
End Property

Public Property Let minHeight(minHeight As Integer)
SubClassInfo.minHeight = minHeight
End Property

Public Property Get lpPrevWndProc() As Long
lpPrevWndProc = SubClassInfo.lpPrevWndProc
End Property

Public Property Let lpPrevWndProc(lpPrevWndProc As Long)
SubClassInfo.lpPrevWndProc = lpPrevWndProc
End Property

'----------------

That should do it

Chaz

 

[bascy]

thanks very much for the quick respons.

Could you edit your respons and place the source-code between

tags. That way it wont get reformated the HTML way and will be easier to copy and paste.

thanks
Bascy

 

[scorpio66]

Oh, 1 thing - when using subclassing in VB it is easy to have VB crash - a lot. Once you are happy this code is working you might want to comment out the Hook and UnHook commands, commenting them back in with each shipping release.

Chaz

 

[rjr9999]

Why refind it? Just re-write it! Try this on for size, it's a bit sloppy, but it works...Unfortunately I havn't yet figured out how to draw outside the form, that's up to you In your form properties make sure you set the form to non-resizable. Also you'll need the two lines drawn out, any size to start...the width and color are up to you. Finally set the two lines styles to 0 (transparent)...and off you go! Hope this helps

Dim MyResize As Integer

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Form1.WindowState = 0) Then
If X > (Form1.Width - 500) And Y > (Form1.Height - 500) And MyResize <> 1 And MyResize <> 2 Then
Form1.MousePointer = 8
If Button = 1 Then
MyResize = 3
End If
ElseIf X > (Form1.Width - 400) And MyResize <> 1 And MyResize <> 3 Then
Form1.MousePointer = 9
If Button = 1 Then
MyResize = 2
End If
ElseIf Y > (Form1.Height - 500) And MyResize <> 2 And MyResize <> 3 Then
Form1.MousePointer = 7
If Button = 1 Then
MyResize = 1
End If
Else
Form1.MousePointer = 1
End If
Call DrawLines(X, Y)
End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
If MyResize = 3 Then
LineHor.BorderStyle = 0
LineVert.BorderStyle = 0
Form1.Height = Y + 300
Form1.Width = X + 50
MyResize = 0
ElseIf MyResize = 2 Then
LineHor.BorderStyle = 0
Form1.Width = X + 50
MyResize = 0
ElseIf MyResize = 1 Then
LineVert.BorderStyle = 0
Form1.Height = Y + 300
MyResize = 0
End If
If Form1.Height < 1000 Then Form1.Height = 1000
If Form1.Width < 1000 Then Form1.Width = 1000
End If
End Sub

Private Sub DrawLines(X As Single, Y As Single)
If MyResize = 3 Then
If X > 1000 And Y > 1000 Then
LineHor.BorderStyle = 1
LineHor.X1 = 0
LineHor.X2 = X
LineHor.Y1 = Y
LineHor.Y2 = Y
LineVert.BorderStyle = 1
LineVert.X1 = X
LineVert.X2 = X
LineVert.Y1 = Y
LineVert.Y2 = 0
ElseIf X < 1000 And Y > 1000 Then
LineHor.BorderStyle = 1
LineVert.BorderStyle = 1
LineHor.X1 = 0
LineHor.X2 = 1000
LineHor.Y1 = Y
LineHor.Y2 = Y
LineVert.X1 = 1000
LineVert.X2 = 1000
LineVert.Y1 = Y
LineVert.Y2 = 0
ElseIf X > 1000 And Y < 1000 Then
LineHor.BorderStyle = 1
LineVert.BorderStyle = 1
LineHor.X1 = 0
LineHor.X2 = X
LineHor.Y1 = 1000
LineHor.Y2 = 1000
LineVert.X1 = X
LineVert.X2 = X
LineVert.Y1 = 1000
LineVert.Y2 = 0
ElseIf X < 1000 And Y < 1000 Then
LineHor.BorderStyle = 1
LineVert.BorderStyle = 1
LineHor.X1 = 0
LineHor.X2 = 1000
LineHor.Y1 = 1000
LineHor.Y2 = 1000
LineVert.X1 = 1000
LineVert.X2 = 1000
LineVert.Y1 = 1000
LineVert.Y2 = 0
End If
ElseIf MyResize = 2 Then
If X > 1000 Then
LineVert.BorderStyle = 1
LineVert.X1 = X
LineVert.X2 = X
LineVert.Y1 = Form1.Height
LineVert.Y2 = 0
End If
ElseIf MyResize = 1 Then
If Y > 1000 Then
LineHor.BorderStyle = 1
LineHor.X1 = 0
LineHor.X2 = Form1.Width
LineHor.Y1 = Y
LineHor.Y2 = Y
End If
End If
End Sub

 

[strongm]

Chaz,

You could always use the TwipsperpixelX and TwipsperpixelY properties of the Screen object for your ConvertTwipsToPixels function...

 

[scorpio66]

Hmm, I'm astounded by this bit of code ... I'm assuming that as you are a developer that you trying to create a bit of mischief.

With your routine you can only make forms smaller, not bigger. You also lose the maximise and minimise buttons. It also looks like no other program on this planet.

As a troll, it is ingenious - I applaud you.

Chaz

 

[rjr9999]

To tell you the truth, I'm a C developer...I used VB for the first time less than a week ago. And yeah, it's a troll I never said it'd be usefull as is, it's just a stepping point to write your own module, that way you can avoid using hooks, and learn something at the same time . Oh, and you can make forms bigger, you just can't see the line display while you're doing it (oops, hehe). Gimmie a chance here, I'm learnin' yet

Rob

 

[strongm]

Also, I should mention that Microsoft released a DLL for VB which makes it safe to debug apps with subclassed windows. Nowadays you need to actually have registered your copy of VB before you can download it, but here's the URL

http://msdn.microsoft.com/vbasic/downloads/download.asp?ID=024

 

[scorpio66]

Mike - that is the most helpful thing I have ever seen - worthy of a rating star if ever I saw one.

Thanks