'以下程式在module1.bas Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long 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 Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Public Const GWL_WNDPROC = (-4) Public Const WM_WINDOWPOSCHANGING = &H46 Type WINDOWPOS hwnd As Long hWndInsertAfter As Long x As Long y As Long cx As Long cy As Long flags As Long End TypePublic preWinProc As Long '而重点就在於Window重新定位之前会传 '出WM_WINDOWPOSCHANGING这个讯息,而lParam指向一个WINDOWPOS的STRUCTURE。 Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Dim lwd As Long, hwd As Long If Msg = WM_WINDOWPOSCHANGING Then Dim WPOS As WINDOWPOS CopyMemory WPOS, ByVal lParam, Len(WPOS) If WPOS.x < 0 Then WPOS.x = 0 '这一句可以使窗体不出屏幕左边界 If WPOS.cx < 400 Then WPOS.cx = 400 '限制窗体的最小宽度,以象素为单位 CopyMemory ByVal lParam, WPOS, Len(WPOS) End If '将之送往原来的Window Procedure wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam) End Function窗体中 Private Sub Form_Load() Dim ret As Long '记录原本的Window Procedure的位址 preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC) ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc) End SubPrivate Sub Form_Unload(Cancel As Integer) Dim ret As Long '取消Message的截取,而使之又只送往原来的Window Procedure ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc) End Sub
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Const GWL_WNDPROC = (-4)
Public Const WM_WINDOWPOSCHANGING = &H46
Type WINDOWPOS
hwnd As Long
hWndInsertAfter As Long
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End TypePublic preWinProc As Long
'而重点就在於Window重新定位之前会传
'出WM_WINDOWPOSCHANGING这个讯息,而lParam指向一个WINDOWPOS的STRUCTURE。
Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lwd As Long, hwd As Long
If Msg = WM_WINDOWPOSCHANGING Then
Dim WPOS As WINDOWPOS
CopyMemory WPOS, ByVal lParam, Len(WPOS)
If WPOS.x < 0 Then WPOS.x = 0 '这一句可以使窗体不出屏幕左边界
If WPOS.cx < 400 Then WPOS.cx = 400 '限制窗体的最小宽度,以象素为单位
CopyMemory ByVal lParam, WPOS, Len(WPOS)
End If
'将之送往原来的Window Procedure
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function窗体中
Private Sub Form_Load()
Dim ret As Long
'记录原本的Window Procedure的位址
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
End SubPrivate Sub Form_Unload(Cancel As Integer)
Dim ret As Long
'取消Message的截取,而使之又只送往原来的Window Procedure
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
End Sub