VB6对滚轮的支持
我需要对Mapx控件支持鼠标滚轮，找了一个可以使用的代码，来自
http://blog.csdn.net/areful/archive/2007/10/19/1832010.aspx
需要注意的是，在FormLoad中增加Hook Map1.hWnd，在Form_Unload中增加UnHook Map1.hWnd
另外，在鼠标移动经过Map时，可以激发Map的mousemove事件，但滚轮无效，因为焦点不在Map上，可以用Map1.SetFocus来设置焦点。
模块代码：
Option
Explicit
Public
Type POINTL
X
As
Long
Y
As
Long
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
Function
SystemParametersInfo Lib
"
USER32
"
Alias
"
SystemParametersInfoA
"
(ByVal uAction
As
Long
, ByVal uParam
As
Long
, lpvParam
As
Any, ByVal fuWinIni
As
Long
)
As
Long
Declare
Function
ScreenToClient Lib
"
USER32
"
(ByVal hWnd
As
Long
, xyPoint
As
POINTL)
As
Long
Public
Const
GWL_WNDPROC
=
-
4
Public
Const
SPI_GETWHEELSCROLLLINES
=
104
Public
Const
WM_MOUSEWHEEL
=
&
H20A
Public
WHEEL_SCROLL_LINES
As
Long
Global lpPrevWndProc
As
Long
Public
sngX
As
Single
, sngY
As
Single
'
鼠标坐标
Public
intShift
As
Integer
'
鼠标按键
Public
bWay
As
Boolean
'
鼠标方向
Public
bMouseFlag
As
Boolean
'
鼠标事件激活标志
'
*************************************************************************
'
**函 数 名：Hook
'
**输 入：ByVal hWnd(Long) - 窗口句柄
'
**输 出：无
'
**功能描述：安装鼠标钩子
'
*************************************************************************
Public
Sub
Hook(ByVal hWnd
As
Long
)
lpPrevWndProc
=
SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
'
获取"控制面板"中的滚动行数值
Call
SystemParametersInfo(SPI_GETWHEELSCROLLLINES,
0
, WHEEL_SCROLL_LINES,
0
)
End Sub
'
*************************************************************************
'
**函 数 名：UnHook
'
**输 入：ByVal hWnd(Long) - 窗口句柄
'
**输 出：无
'
**功能描述：卸载鼠标钩子
'
*************************************************************************
Public
Sub
UnHook(ByVal hWnd
As
Long
)
Dim
lngReturnValue
As
Long
lngReturnValue
=
SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
'
*************************************************************************
'
**函 数 名：WindowProc
'
**输 入：ByVal hw(Long) - 窗口句柄
'
** ：ByVal uMsg(Long) - 消息类型
'
** ：ByVal wParam(Long) -
'
** ：ByVal lParam(Long) -
'
*************************************************************************
Private
Function
WindowProc(ByVal hw
As
Long
, ByVal uMsg
As
Long
, ByVal wParam
As
Long
, ByVal lParam
As
Long
)
As
Long
Dim
pt
As
POINTL
Select
Case
uMsg
Case
WM_MOUSEWHEEL
'
滚动
Dim
wzDelta, wKeys
As
Integer
'
wzDelta传递滚轮滚动的快慢，该值小于零表示滚轮向后滚动（朝用户方向），
'
大于零表示滚轮向前滚动（朝显示器方向）
wzDelta
=
HIWORD(wParam)
'
wKeys指出是否有CTRL=8、SHIFT=4、鼠标键(左=2、中=16、右=2、附加)按下，允许复合
wKeys
=
LOWORD(wParam)
'
pt鼠标的坐标
pt.X
=
LOWORD(lParam)
pt.Y
=
HIWORD(lParam)
'
--------------------------------------------------
If
wzDelta
<
0
Then
'
朝用户方向
bWay
=
True
'
在这里你自己处理－－－－－－－－－－－－－－－－－－
main.Cmap.ZoomOut
'
MsgBox 0 '这行代码由我加入，使用时改为你自己的代码
Else
'
朝显示器方向
bWay
=
False
main.Cmap.ZoomIn
'
MsgBox 1 '这行代码由我加入，使用时改为你自己的代码
End
If
'
--------------------------------------------------
'
将屏幕坐标转换为Form1.窗口坐标
ScreenToClient hw, pt
sngX
=
pt.X
sngY
=
pt.Y
intShift
=
wKeys
bMouseFlag
=
True
'
置滚动标志
Case
Else
WindowProc
=
CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End
Select
End Function
'
*************************************************************************
'
**函 数 名：HIWORD
'
**输 入：LongIn(Long) - 32位值
'
**输 出：(Integer) - 32位值的低16位
'
**功能描述：取出32位值的高16位
'
*************************************************************************
Public
Function
HIWORD(LongIn
As
Long
)
As
Integer
'
取出32位值的高16位
HIWORD
=
(LongIn
And
&
HFFFF0000)
\
&
H10000
End Function
'
*************************************************************************
'
**函 数 名：LOWORD
'
**输 入：LongIn(Long) - 32位值
'
**输 出：(Integer) - 32位值的低16位
'
**功能描述：取出32位值的低16位
'
*************************************************************************
Public
Function
LOWORD(LongIn
As
Long
)
As
Integer
'
取出32位值的低16位
LOWORD
=
LongIn
And
&
HFFFF
&
End Function
http://blog.csdn.net/areful/archive/2007/10/19/1832010.aspx
需要注意的是，在FormLoad中增加Hook Map1.hWnd，在Form_Unload中增加UnHook Map1.hWnd
另外，在鼠标移动经过Map时，可以激发Map的mousemove事件，但滚轮无效，因为焦点不在Map上，可以用Map1.SetFocus来设置焦点。
模块代码：
Option
Explicit
Public
Type POINTLX
As
Long
Y
As
Long
End
TypeDeclare
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
Function
SystemParametersInfo Lib
"
USER32
"
Alias
"
SystemParametersInfoA
"
(ByVal uAction
As
Long
, ByVal uParam
As
Long
, lpvParam
As
Any, ByVal fuWinIni
As
Long
)
As
Long
Declare
Function
ScreenToClient Lib
"
USER32
"
(ByVal hWnd
As
Long
, xyPoint
As
POINTL)
As
Long
Public
Const
GWL_WNDPROC
=
-
4
Public
Const
SPI_GETWHEELSCROLLLINES
=
104
Public
Const
WM_MOUSEWHEEL
=
&
H20A
Public
WHEEL_SCROLL_LINES
As
Long
Global lpPrevWndProc
As
Long
Public
sngX
As
Single
, sngY
As
Single
'
鼠标坐标
Public
intShift
As
Integer
'
鼠标按键
Public
bWay
As
Boolean
'
鼠标方向
Public
bMouseFlag
As
Boolean
'
鼠标事件激活标志
'
*************************************************************************
'
**函 数 名：Hook
'
**输 入：ByVal hWnd(Long) - 窗口句柄
'
**输 出：无
'
**功能描述：安装鼠标钩子
'
*************************************************************************
Public
Sub
Hook(ByVal hWnd
As
Long
) lpPrevWndProc
=
SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
'
获取"控制面板"中的滚动行数值
Call
SystemParametersInfo(SPI_GETWHEELSCROLLLINES,
0
, WHEEL_SCROLL_LINES,
0
)
End Sub
'
*************************************************************************
'
**函 数 名：UnHook
'
**输 入：ByVal hWnd(Long) - 窗口句柄
'
**输 出：无
'
**功能描述：卸载鼠标钩子
'
*************************************************************************
Public
Sub
UnHook(ByVal hWnd
As
Long
)
Dim
lngReturnValue
As
Long
lngReturnValue
=
SetWindowLong(hWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
'
*************************************************************************
'
**函 数 名：WindowProc
'
**输 入：ByVal hw(Long) - 窗口句柄
'
** ：ByVal uMsg(Long) - 消息类型
'
** ：ByVal wParam(Long) -
'
** ：ByVal lParam(Long) -
'
*************************************************************************
Private
Function
WindowProc(ByVal hw
As
Long
, ByVal uMsg
As
Long
, ByVal wParam
As
Long
, ByVal lParam
As
Long
)
As
Long
Dim
pt
As
POINTL
Select
Case
uMsg
Case
WM_MOUSEWHEEL
'
滚动
Dim
wzDelta, wKeys
As
Integer
'
wzDelta传递滚轮滚动的快慢，该值小于零表示滚轮向后滚动（朝用户方向），
'
大于零表示滚轮向前滚动（朝显示器方向）
wzDelta
=
HIWORD(wParam)
'
wKeys指出是否有CTRL=8、SHIFT=4、鼠标键(左=2、中=16、右=2、附加)按下，允许复合
wKeys
=
LOWORD(wParam)
'
pt鼠标的坐标
pt.X
=
LOWORD(lParam) pt.Y
=
HIWORD(lParam)
'
--------------------------------------------------
If
wzDelta
<
0
Then
'
朝用户方向
bWay
=
True
'
在这里你自己处理－－－－－－－－－－－－－－－－－－
main.Cmap.ZoomOut
'
MsgBox 0 '这行代码由我加入，使用时改为你自己的代码
Else
'
朝显示器方向
bWay
=
False
main.Cmap.ZoomIn
'
MsgBox 1 '这行代码由我加入，使用时改为你自己的代码
End
If
'
--------------------------------------------------
'
将屏幕坐标转换为Form1.窗口坐标
ScreenToClient hw, pt sngX
=
pt.X sngY
=
pt.Y intShift
=
wKeys bMouseFlag
=
True
'
置滚动标志
Case
Else
WindowProc
=
CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End
Select
End Function
'
*************************************************************************
'
**函 数 名：HIWORD
'
**输 入：LongIn(Long) - 32位值
'
**输 出：(Integer) - 32位值的低16位
'
**功能描述：取出32位值的高16位
'
*************************************************************************
Public
Function
HIWORD(LongIn
As
Long
)
As
Integer
'
取出32位值的高16位
HIWORD
=
(LongIn
And
&
HFFFF0000)
\
&
H10000
End Function
'
*************************************************************************
'
**函 数 名：LOWORD
'
**输 入：LongIn(Long) - 32位值
'
**输 出：(Integer) - 32位值的低16位
'
**功能描述：取出32位值的低16位
'
*************************************************************************
Public
Function
LOWORD(LongIn
As
Long
)
As
Integer
'
取出32位值的低16位
LOWORD
=
LongIn
And
&
HFFFF
&
End Function