Question

我在窗体上画了一个位图，现在想实现滚动鼠标中键，使图像放大、缩小。该如何做呢？

Answer 1

VB中只有Combox支持鼠标滚动，我是这么解决的：
在外面放一个Combox为combo1
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 38 Then
'鼠标上滚

end if

If KeyCode = 40Then

'鼠标下滚

end if

End Sub

Private Sub Combo1_LostFocus()
Combo1.SetFocus ‘保证combo1不失去焦点
End Sub
希望对你有帮助

Answer 2

'// Author: Qf
modSubClass.bas
Option Explicit
'// 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.picImage.Width = frmTest.picImage.Width - 100
frmTest.picImage.Height = frmTest.picImage.Height - 100
' 放大图片
Else
frmTest.picImage.Width = frmTest.picImage.Width + 100
frmTest.picImage.Height = frmTest.picImage.Height + 100
End If
StretchPic frmTest.picImage
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
frmTest.frm
Option Explicit
Private Sub Form_Load()

Me.picImage.AutoRedraw = True
Me.picImage.ScaleMode = vbPixels

SubClasss Me.picImage.hWnd

End Sub
Private Sub Form_Unload(Cancel As Integer)

UnSubClasss Me.picImage.hWnd

End Sub