كيف يمكن ان امنع المستخدم من تكبير الفورم اوتصغيره عن طريق الماوس بدون الغاء الازار الموجوده اعلاء الفورم ؟؟؟

السلام عليكم ورحمة الله وبركاته

Private Sub Form_Resize()
'إذا أردت تفعيل تكبير كامل أو تصغير كامل فقط
If WindowState = 1 Or WindowState = 2 Then
'لاتعمل شي
Else
Me.Width = 10000
Me.Height = 5000
End If
End Sub

فى Module

Option Explicit

Private 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
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

' Constants
Private Const WM_GETMINMAXINFO As Long = &H24
Global Const GWL_WNDPROC = (-4)

' Types
Private Type POINTAPI
X As Long
Y As Long
End Type

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

' misc variabels
Private SizeInfo As MINMAXINFO
Public lngOldProc As Long
Dim ResY As Long
Dim ResX As Long


Public Function SubClass_Proc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

If uMsg = WM_GETMINMAXINFO Then
Call RtlMoveMemory(ByVal lParam, SizeInfo, LenB(SizeInfo)) ' Set the new size info for my form
Else
SubClass_Proc = CallWindowProc(lngOldProc, hWnd, uMsg, wParam, lParam) ' go on as normal if the uMsg isnt resizing
End If

End Function
Public Sub SetMaxMin()
With SizeInfo
' Maximised position
.ptMaxPosition.X = 100
.ptMaxPosition.Y = 100

'Maximized size
.ptMaxSize.X = 640
.ptMaxSize.Y = 480

'Maximum size with re-sizing
.ptMaxTrackSize.X = 640
.ptMaxTrackSize.Y = 480

'Minimum size with re-sizing
.ptMinTrackSize.X = 320
.ptMinTrackSize.Y = 280

End With
End Sub

فى حدث الـ Load

SetMaxMin
lngOldProc = SetWindowLongA(Me.hWnd, GWL_WNDPROC, AddressOf SubClass_Proc)

فى حدث الـ Unload

SetWindowLongA Me.hWnd, GWL_WNDPROC, lngOldProc

طريقة أخرى

'/////////////
'* In a form *
'/////////////

Option Explicit

Private Sub Form_Load()
Call Hook(Me.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call Unhook(Me.hWnd)
End Sub

'////////////////////////
'* In a standard module *
'////////////////////////

Option Explicit

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long
Private 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
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Const GWL_WNDPROC = (-4)

Private Const WM_SIZING = &H214

Private Const WMSZ_LEFT = 1
Private Const WMSZ_RIGHT = 2
Private Const WMSZ_TOP = 3
Private Const WMSZ_TOPLEFT = 4
Private Const WMSZ_TOPRIGHT = 5
Private Const WMSZ_BOTTOM = 6
Private Const WMSZ_BOTTOMLEFT = 7
Private Const WMSZ_BOTTOMRIGHT = 8

Private Const MIN_WIDTH = 200 'The minimum width in pixels
Private Const MIN_HEIGHT = 200 'The minimum height in pixels
Private Const MAX_WIDTH = 500 'The maximum width in pixels
Private Const MAX_HEIGHT = 500 'The maximum height in pixels

Private Type RECT
Left As Long
Top As Long
RIGHT As Long
Bottom As Long
End Type

Private mPrevProc As Long

Public Sub Hook(hWnd As Long)
mPrevProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf NewWndProc)
End Sub

Public Sub Unhook(hWnd As Long)

Call SetWindowLong(hWnd, GWL_WNDPROC, mPrevProc)
mPrevProc = 0&

End Sub

Public Function NewWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next

Dim r As RECT

If uMsg = WM_SIZING Then
Call CopyMemory(r, ByVal lParam, Len®)

'Keep the form only at least as wide as MIN_WIDTH
If (r.RIGHT - r.Left < MIN_WIDTH) Then
Select Case wParam
Case WMSZ_LEFT, WMSZ_BOTTOMLEFT, WMSZ_TOPLEFT
r.Left = r.RIGHT - MIN_WIDTH
Case WMSZ_RIGHT, WMSZ_BOTTOMRIGHT, WMSZ_TOPRIGHT
r.RIGHT = r.Left + MIN_WIDTH
End Select
End If

'Keep the form only at least as tall as MIN_HEIGHT
If (r.Bottom - r.Top < MIN_HEIGHT) Then
Select Case wParam
Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT
r.Top = r.Bottom - MIN_HEIGHT
Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT
r.Bottom = r.Top + MIN_HEIGHT
End Select
End If

'Keep the form only as wide as MAX_WIDTH
If (r.RIGHT - r.Left > MAX_WIDTH) Then
Select Case wParam
Case WMSZ_LEFT, WMSZ_BOTTOMLEFT, WMSZ_TOPLEFT
r.Left = r.RIGHT - MAX_WIDTH
Case WMSZ_RIGHT, WMSZ_BOTTOMRIGHT, WMSZ_TOPRIGHT
r.RIGHT = r.Left + MAX_WIDTH
End Select
End If

'Keep the form only as tall as MAX_HEIGHT
If (r.Bottom - r.Top > MAX_HEIGHT) Then
Select Case wParam
Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT
r.Top = r.Bottom - MAX_HEIGHT
Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT
r.Bottom = r.Top + MAX_HEIGHT
End Select
End If

Call CopyMemory(ByVal lParam, r, Len®)

NewWndProc = 0&
Exit Function
End If


If mPrevProc > 0& Then
NewWndProc = CallWindowProc(mPrevProc, hWnd, uMsg, wParam, lParam)
Else
NewWndProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
End If

End Function

السلام عليكم

يعطيك العافية أخي msayed2004لدي استفسار بعد إذنك

بالنسبة للكود الأول جربته عمل تمام

لكن بعد نقل التعريف التالي من الموديول الى الفورم(للتوضيح)

Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

لكن العجيب في الكود الثاني فعندما تشغله يغلق البيسك كاملاً

أظن أن الرمز ® لم يرق له لكن لماذا يغلق البرنامج كله

هل الغلق ده حصل من أول شغل لكود ولا بعد الضغط على زر الأيقاف بالـ VB ولا نسيت تحط الكود فى حدث الـ Unload

الكود ده بيعمل Subcalssing على الفورم بأستخدام UnSafe subclasser وبالتالى يجب عدم أيقاف البرنامج من الـ VB و يجب و ضع كود حدث الـ Unload

السلام عليكم

اقتباس

هل الغلق ده حصل من أول شغل لكود

نعم عند التشغيل

وهناك كمان طرقة اخرى للتذكير فقط

ضع تايمر وعين القيمة 1 له في خاصية ال interval

Dim v
Private Sub Form_Load()
v = Me.WindowState
End Sub

Private Sub Timer1_Timer()
If Me.WindowState = 2 Then'عند التكبير
Me.WindowState = v
End If



End Sub

شرح الكود انا خزنت القيمة الافتراضية لحالة الفورم يعني اذا اكان عند التحميل مكبر او عادي اذا كان عادي وقام المستخدم بتكبيره يرحعو زي ماكان وانتا كما اتتنسى تلعب بالكود على كيفك

وهناك كمان طرقة اخرى للتذكير فقط

ضع تايمر وعين القيمة 1 له في خاصية ال interval

Dim v
Private Sub Form_Load()
v = Me.WindowState
End Sub

Private Sub Timer1_Timer()
If Me.WindowState = 2 Then'عند التكبير
Me.WindowState = v
End If



End Sub

شرح الكود انا خزنت القيمة الافتراضية لحالة الفورم يعني اذا اكان عند التحميل مكبر او عادي اذا كان عادي وقام المستخدم بتكبيره يرحعو زي ماكان وانتا كما اتتنسى تلعب بالكود على كيفك

المشروع شغال معايا بدون مشاكل , يمكن نسخت حاجة غلط , جرب الملف المرفق. أخى mostafazidani معظم الأكواد دى لما تتحط فى حدث الـ Resize هيحصل Flickering لما المستخدم يجى يحاول يكبر أو يصغر , و حاول دايما تبعد عن أستخدام الـ Timer

Limited_form.rar

اقتباس

أظن أن الرمز ® لم يرق له لكن لماذا يغلق البرنامج كله

عملت مقارنة مع الكودين فوجدت أن الكود الأول يلي فيه الخطأ يحول

Len® إلى Len(® )

يبدو أن الخطأ في تنسيق الكود في المنتدى

انحلت المشكلة

يعطيك العافية أخي Mohammed Sayed

الأخ الفاضل ...

StopMinMax.zip

مرفق مثال بأستخدام (MS-VB 6.0)

يمكنك ذلك ببساطة بالحصول على مقبض قائمة النظام (System Menu) وإزالة البندين (تكبير وتصغير) والذى يعتمد عليهم عمل الأزرار

Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Private Const SC_MINIMIZE = &HF020&
Private Const SC_MAXIMIZE = &HF030&

Private Sub Form_Load()
	Dim hSystemMenu As Long

	hSystemMenu = GetSystemMenu(Me.hwnd, 0)
	Call RemoveMenu(hSystemMenu, SC_MINIMIZE, 0)
	Call RemoveMenu(hSystemMenu, SC_MAXIMIZE, 0)
End Sub

شكراً

سوف اجرب وارى وشكرا لكم جميعا