Ответить

Попробуй как то так:

Private Declare Function SendMessage _

Lib "user32" Alias "SendMessageA" _

(ByVal hWnd As Long, ByVal wMsg As Long, _

ByVal wParam As Long, lParam As Any) As Long

Private Declare Function ReleaseCapture Lib "user32" () As Long

Const WM_NCLBUTTONDOWN = &HA1

Const HTCAPTION = 2 'перетаскивание за форму

Const HTBOTTOM = 15 'ресайз за нижнюю рамку

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Y > Form1.Height - 100 Then

Me.MousePointer = 7

ReleaseCapture

SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0&

Me.MousePointer = 0

End If

End Sub

Ответить

Ответить

Ответить

Был пример с сабклассингом, запрещающий менять размер вне некоторых пределов...

' Модуль

Option Explicit
 
'Эжели хоца, сделайте из этого модуля класс
'я попробовал, не получилось, а возиться не хочеться
 
Private Const GWL_WNDPROC = -4
Private Const WM_GETMINMAXINFO = &H24
 
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
 
Dim lpPrevWndProc As Long
Dim gHW As Long
 
Private Type Resize
    xMin As Single
    yMin As Single
    xMax As Single
    yMax As Single
End Type
 
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 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub CopyMemoryToMinMaxInfo Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As MINMAXINFO, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub CopyMemoryFromMinMaxInfo Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, hpvSource As MINMAXINFO, ByVal cbCopy As Long)
Dim rResize As Resize
 
Public Sub Hook(ByVal wHWND As Long, Optional ByVal X_Min As Single = 0, Optional ByVal Y_Min As Single = 0, Optional ByVal X_Max As Single = 0, Optional ByVal Y_Max As Single = 0)
    'Стартуем сабклассинг
    gHW = wHWND 'запомним хэндл, чтобы воспользоваться им при остановке классинга
    rResize.xMax = X_Max
    rResize.yMax = Y_Max
    rResize.xMin = X_Min
    rResize.yMin = Y_Min
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub
 
Public Sub Unhook()
    Dim temp As Long
    'Останавливаем сабклассинг
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
 
Private Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim MinMax As MINMAXINFO
 
    'Проверка, ресайзим ли мы окно
    If uMsg = WM_GETMINMAXINFO Then
        'Необходимо для заголовка child MDI окна (когда развернуто на весь экран)
        WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
        'получаем заданные по умолчанию параметры настройки Минимакса
        CopyMemoryToMinMaxInfo MinMax, lParam, Len(MinMax)
 
        'Определяем новый минимальный размер окна
        'Если не присвоить какое-либо значение в MinMax.ptMinTrackSize.x(y), то
        'При ресайзе это значение будет игнорироваться. Тоже самое и для максимальног значения
        If rResize.xMin <> 0 Then MinMax.ptMinTrackSize.x = rResize.xMin
        If rResize.yMin <> 0 Then MinMax.ptMinTrackSize.y = rResize.yMin
 
        'Определяем новый максимальный размер окна
        If rResize.xMax <> 0 Then MinMax.ptMaxTrackSize.x = rResize.xMax
        If rResize.yMax <> 0 Then MinMax.ptMaxTrackSize.y = rResize.yMax
 
        'Копируем нашу структуру обратно
        CopyMemoryFromMinMaxInfo lParam, MinMax, Len(MinMax)
 
        WindowProc = DefWindowProc(hw, uMsg, wParam, lParam)
    Else
        WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    End If
End Function

Private Sub Form_Load()
    Me.Height = 500 * Screen.TwipsPerPixelY
    Me.Width = 500 * Screen.TwipsPerPixelX
    'стартуем
    Hook Me.hwnd, 100, 100, 500, 500
End Sub
 
Private Sub Form_Resize()
    Label1.Caption = CStr(Me.Height \ Screen.TwipsPerPixelY) & "\" & CStr(Me.Width \ Screen.TwipsPerPixelX)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'ВНИМАНИЕ ЭТО ВАЖНО
    ' НЕОБХОДИМО ОСТАНОВИТЬ САБКЛАССИНГ
    Unhook
End Sub

Ответить