mousem.bas

功能强大的个人工作通讯录

Attribute VB_Name = "mouseM"
'// Author: Qf
'modSubClass.bas代码
Option Explicit

Public frmTest As Form

'// BitBlt API dwRop parameter constants
Private Const SRCAND = &H8800C6          ' (DWORD) dest = source AND dest
Private Const SRCCOPY = &HCC0020         ' (DWORD) dest = source
Private Const SRCERASE = &H440328        ' (DWORD) dest = source AND (NOT dest )
Private Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
Private Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
Private Const SRCMERGEPAINT = &HBB0226
Private Const SRCDSNA = &H220326
'// SetStretchBltMode API nStretchMode parameter constants
Private Const STRETCH_ANDSCANS = 1
Private Const STRETCH_ORSCANS = 2
Private Const STRETCH_DELETESCANS = 3
Private Const STRETCH_HALFTONE = 4

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 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 Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL = &H20A



Private m_lpPreWndFunc As Long            '// 默认窗口处理函数地址

Public Sub SubClasss(ByVal hWnd As Long)

    m_lpPreWndFunc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindProc)
    
End Sub

Public Sub UnSubClasss(ByVal hWnd As Long)

    SetWindowLong hWnd, GWL_WNDPROC, m_lpPreWndFunc
    
End Sub

Public Function WindProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Select Case uMsg
        Case WM_MOUSEWHEEL
             ' 缩小图片
             If wParam > 0 Then
                frmTest.Picture1.Width = frmTest.Picture1.Width * 0.9
                frmTest.Picture1.Height = frmTest.Picture1.Height * 0.9
             ' 放大图片
             Else
                frmTest.Picture1.Width = frmTest.Picture1.Width * 1.1
                frmTest.Picture1.Height = frmTest.Picture1.Height * 1.1
             End If
             StretchPic frmTest.Picture1
             frmTest.Picture1.Left = frmTest.Picture2.Width / 2 - frmTest.Picture1.Width / 2 - 32.5
             frmTest.Picture1.Top = frmTest.Picture2.Height / 2 - frmTest.Picture1.Height / 2
        Case Else
             WindProc = CallWindowProc(m_lpPreWndFunc, hWnd, uMsg, wParam, lParam)
    End Select
    
End Function

'//
'// 放大缩小图片
'//
Public Sub StretchPic(dstPic As PictureBox)
 
    Dim lngOldDIB As Long
    Dim lngOldMode As Long
    Dim lnghDC As Long
    Dim lngMHDC As Long
    Dim lngSrcX As Long
    Dim lngSrcY As Long
     
    dstPic.AutoRedraw = True
    dstPic.ScaleMode = vbPixels
    
    lnghDC = GetDC(dstPic.hWnd)
    lngMHDC = CreateCompatibleDC(lnghDC)
    ReleaseDC dstPic.hWnd, lnghDC
       
    lngSrcX = dstPic.ScaleX(dstPic.Picture.Width, vbHimetric, vbPixels)
    lngSrcY = dstPic.ScaleY(dstPic.Picture.Height, vbHimetric, vbPixels)
    lngOldDIB = SelectObject(lngMHDC, dstPic.Picture.Handle)
    lngOldMode = SetStretchBltMode(dstPic.hdc, STRETCH_DELETESCANS)
    StretchBlt dstPic.hdc, 0, 0, dstPic.ScaleWidth, dstPic.ScaleHeight, _
               lngMHDC, 0, 0, lngSrcX, lngSrcY, vbSrcCopy
    SetStretchBltMode dstPic.hdc, lngOldMode
    dstPic.Refresh
    
    SelectObject lngMHDC, lngOldDIB
    DeleteObject lngOldDIB
    DeleteDC lngMHDC
    
End Sub