Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0759: Minimale/maximale Fenstergröße per Subclassing

VB 5/6-Tipp 0759: Minimale/maximale Fenstergröße per Subclassing

 von TiKu

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMemory), DefSubclassProc, RemoveWindowSubclass, SetWindowSubclass, RtlZeroMemory (ZeroMemory)

Download: Download des Beispielprojektes [4.22 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Schaltfläche "cmdSetToLargerSize"
' Steuerelement: Kontrollkästchen-Steuerelement "chkHandleWindowPosChanged"
' Steuerelement: Schaltfläche "cmdSetToSmallerSize"
Option Explicit

  Private Const MAXHEIGHT As Long = 500
  Private Const MAXWIDTH As Long = 600
  Private Const MINHEIGHT As Long = 200
  Private Const MINWIDTH As Long = 300


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

  Private Type WINDOWPOS
    hWnd As Long
    hWndInsertAfter As Long
    x As Long
    y As Long
    cx As Long
    cy As Long
    Flags As Long
  End Type


  Implements ISubclassedWindow


Private Sub cmdSetToLargerSize_Click()
  Me.Move Me.Left, Me.Top, Me.ScaleX(800, ScaleModeConstants.vbPixels, Me.ScaleMode), Me.ScaleY(600, ScaleModeConstants.vbPixels, Me.ScaleMode)
End Sub

Private Sub cmdSetToSmallerSize_Click()
  Me.Move Me.Left, Me.Top, Me.ScaleX(200, ScaleModeConstants.vbPixels, Me.ScaleMode), Me.ScaleY(350, ScaleModeConstants.vbPixels, Me.ScaleMode)
End Sub

Private Sub Form_Load()
  If Not SubclassWindow(Me.hWnd, Me, EnumSubclassID.escidFrmMain) Then
    Debug.Print "Subclassing failed!"
  End If
End Sub

Private Sub Form_Resize()
  Me.Caption = "Size: " & CStr(Me.ScaleX(Me.Width, Me.ScaleMode, ScaleModeConstants.vbPixels)) & "x" & CStr(Me.ScaleY(Me.Height, Me.ScaleMode, ScaleModeConstants.vbPixels))
End Sub

Private Sub Form_Unload(Cancel As Integer)
  If Not UnSubclassWindow(Me.hWnd, EnumSubclassID.escidFrmMain) Then
    Debug.Print "UnSubclassing failed!"
  End If
End Sub

Private Function ISubclassedWindow_HandleMessage(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal eSubclassID As EnumSubclassID, bCallDefProc As Boolean) As Long
  Dim lRet As Long

  On Error Goto StdHandler_Error
  Select Case eSubclassID
    Case EnumSubclassID.escidFrmMain
      lRet = HandleMessage_Form(hWnd, uMsg, wParam, lParam, bCallDefProc)
    Case Else
      Debug.Print "frmMain.ISubclassedWindow_HandleMessage: Unknown Subclassing ID " & CStr(eSubclassID)
  End Select

StdHandler_Ende:
  ISubclassedWindow_HandleMessage = lRet
  Exit Function

StdHandler_Error:
  Debug.Print "Error in frmMain.ISubclassedWindow_HandleMessage (SubclassID=" & CStr(eSubclassID) & ": ", Err.Number, Err.Description
  Resume StdHandler_Ende
End Function

Private Function HandleMessage_Form(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, bCallDefProc As Boolean) As Long
  Const WM_SIZING = &H214
  Const WM_WINDOWPOSCHANGED = &H47
  Const WMSZ_BOTTOMLEFT = 7
  Const WMSZ_LEFT = 1
  Const WMSZ_TOP = 3
  Const WMSZ_TOPLEFT = 4
  Const WMSZ_TOPRIGHT = 5
  Dim lRet As Long
  Dim tRect As RECT
  Dim tWindowPos As WINDOWPOS

  On Error Goto StdHandler_Error
  Select Case uMsg
    Case WM_SIZING
      CopyMemory VarPtr(tRect), lParam, LenB(tRect)
      If tRect.Right - tRect.Left < MINWIDTH Then
        Select Case wParam
          Case WMSZ_TOPLEFT, WMSZ_LEFT, WMSZ_BOTTOMLEFT
            tRect.Left = tRect.Right - MINWIDTH
          Case Else
            tRect.Right = tRect.Left + MINWIDTH
        End Select
      ElseIf tRect.Right - tRect.Left > MAXWIDTH Then
        Select Case wParam
          Case WMSZ_TOPLEFT, WMSZ_LEFT, WMSZ_BOTTOMLEFT
            tRect.Left = tRect.Right - MAXWIDTH
          Case Else
            tRect.Right = tRect.Left + MAXWIDTH
        End Select
      End If
      If tRect.Bottom - tRect.Top < MINHEIGHT Then
        Select Case wParam
          Case WMSZ_TOPLEFT, WMSZ_TOP, WMSZ_TOPRIGHT
            tRect.Top = tRect.Bottom - MINHEIGHT
          Case Else
            tRect.Bottom = tRect.Top + MINHEIGHT
        End Select
      ElseIf tRect.Bottom - tRect.Top > MAXHEIGHT Then
        Select Case wParam
          Case WMSZ_TOPLEFT, WMSZ_TOP, WMSZ_TOPRIGHT
            tRect.Top = tRect.Bottom - MAXHEIGHT
          Case Else
            tRect.Bottom = tRect.Top + MAXHEIGHT
        End Select
      End If
      CopyMemory lParam, VarPtr(tRect), LenB(tRect)

    Case WM_WINDOWPOSCHANGED
      If chkHandleWindowPosChanged.Value = vbChecked Then
        CopyMemory VarPtr(tWindowPos), lParam, LenB(tWindowPos)
        If tWindowPos.cx < MINWIDTH Then
          On Error Resume Next
          Me.Width = ScaleX(MINWIDTH, ScaleModeConstants.vbPixels, Me.ScaleMode)
        ElseIf tWindowPos.cx > MAXWIDTH Then
          On Error Resume Next
          Me.Width = ScaleX(MAXWIDTH, ScaleModeConstants.vbPixels, Me.ScaleMode)
        End If
        If tWindowPos.cy < MINHEIGHT Then
          On Error Resume Next
          Me.Height = ScaleY(MINHEIGHT, ScaleModeConstants.vbPixels, Me.ScaleMode)
        ElseIf tWindowPos.cy > MAXHEIGHT Then
          On Error Resume Next
          Me.Height = ScaleY(MAXHEIGHT, ScaleModeConstants.vbPixels, Me.ScaleMode)
        End If
      End If
  End Select

StdHandler_Ende:
  HandleMessage_Form = lRet
  Exit Function

StdHandler_Error:
  Debug.Print "Error in frmMain.HandleMessage_Form: ", Err.Number, Err.Description
  Resume StdHandler_Ende
End Function
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'--- Anfang Klasse "ISubclassedWindow" alias ISubclassedWindow.cls  ---
Option Explicit

Public Function HandleMessage(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal eSubclassID As EnumSubclassID, ByRef bCallDefProc As Boolean) As Long
  '
End Function
'--- Ende Klasse "ISubclassedWindow" alias ISubclassedWindow.cls  ---
'--- Anfang Modul "basSubclassing" alias basSubclassing.bas ---
Option Explicit

  Public Enum EnumSubclassID
    escidFrmMain = 1
    'escidFrmMainCmdOk
    '...
  End Enum


  Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
  Private Declare Function SetWindowSubclass Lib "comctl32.dll" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
  Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByVal pDest As Long, ByVal sz As Long)

  Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal sz As Long)
  Public Declare Function DefSubclassProc Lib "comctl32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long


Public Function SubclassProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
  Dim bCallDefProc As Boolean
  Dim oClient As ISubclassedWindow
  Dim lRet As Long

  On Error Goto StdHandler_Error
  bCallDefProc = True
  If dwRefData Then
    Set oClient = GetObjectFromPointer(dwRefData)
    If Not (oClient Is Nothing) Then
      lRet = oClient.HandleMessage(hWnd, uMsg, wParam, lParam, uIdSubclass, bCallDefProc)
    End If
  End If

StdHandler_Ende:
  On Error Resume Next
  If bCallDefProc Then
    lRet = DefSubclassProc(hWnd, uMsg, wParam, lParam)
  End If
  SubclassProc = lRet
  Exit Function

StdHandler_Error:
  Debug.Print "Error in SubclassProc: ", Err.Number, Err.Description
  Resume StdHandler_Ende
End Function

Public Function SubclassWindow(ByVal hWnd As Long, oClient As ISubclassedWindow, ByVal eSubclassID As EnumSubclassID) As Boolean
  Dim bRet As Boolean

  On Error Goto StdHandler_Error
  If SetWindowSubclass(hWnd, AddressOf basSubclassing.SubclassProc, eSubclassID, ObjPtr(oClient)) Then
    bRet = True
  End If

StdHandler_Ende:
  SubclassWindow = bRet
  Exit Function

StdHandler_Error:
  Debug.Print "Error in SubclassWindow: ", Err.Number, Err.Description
  bRet = False
  Resume StdHandler_Ende
End Function

Public Function UnSubclassWindow(ByVal hWnd As Long, ByVal eSubclassID As EnumSubclassID) As Boolean
  Dim bRet As Boolean

  On Error Goto StdHandler_Error
  If RemoveWindowSubclass(hWnd, AddressOf basSubclassing.SubclassProc, eSubclassID) Then
    bRet = True
  End If

StdHandler_Ende:
  UnSubclassWindow = bRet
  Exit Function

StdHandler_Error:
  Debug.Print "Error in UnSubclassWindow: ", Err.Number, Err.Description
  bRet = False
  Resume StdHandler_Ende
End Function

' returns the object <lPtr> points to
Private Function GetObjectFromPointer(ByVal lPtr As Long) As Object
  Dim oRet As Object

  ' get the object <lPtr> points to
  CopyMemory VarPtr(oRet), VarPtr(lPtr), LenB(lPtr)
  Set GetObjectFromPointer = oRet
  ' free memory
  ZeroMemory VarPtr(oRet), 4
End Function
'--- Ende Modul "basSubclassing" alias basSubclassing.bas ---
'-------------- Ende Projektdatei Projekt1.vbp --------------