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

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

相关文章

来自专栏码匠的流水账

Flux OOM实例

reactor-core-3.1.3.RELEASE-sources.jar!/reactor/core/publisher/FluxSink.java

1031
来自专栏小樱的经验随笔

Codeforces 768B Code For 1

B. Code For 1 time limit per test:2 seconds memory limit per test:256 megabytes ...

3688
来自专栏码匠的流水账

FluxSink实例及解析

reactor-core-3.1.3.RELEASE-sources.jar!/reactor/core/publisher/FluxSink.java

1522
来自专栏叁金大数据

C#调用C++ Dll

现在项目基本都是旁边C++的哥们做好dll扔给我,然后我调用。好久之前晚上down了一份c#调用c++dll的方法,出处早已经遗忘。闲来无事,放上来好了。原作者...

4062
来自专栏前端新视界

由移动端级联选择器所引发的对于数据结构的思考

GitHub:https://github.com/nzbin/Framework7-CityPicker Demo:https://nzbin.githu...

3988
来自专栏曾大稳的博客

Android ClassLoader流程解读并简单方式实现热更新

ClassLoader在启动Activity的时候会调用loadClass方法,我们就从这里入手:

2952
来自专栏GIS讲堂

Openlayers2卷帘功能的实现

在WebGIS开发中,经常会有用户提需求,要实现卷帘功能,卷帘功能主要是实现两张图之间的对比。在前文中,讲到了openlayers3以及Arcgis for j...

1702
来自专栏跟着阿笨一起玩NET

C# DataGridView样式 (蓝色)

2152
来自专栏landv

vb.net_一个半成品

1854
来自专栏猿人谷

网页抓取

之前做聊天室时,由于在聊天室中提供了新闻阅读的功能,写了一个从网页中抓取信息(如最新的头条新闻,新闻的来源,标题,内容等)的类,本文将介绍如何使用这个类来抓取网...

2628

扫码关注云+社区

领取腾讯云代金券