快来呀！让你的HFlexGrid也支持滚轮！！自写代码，请指教！

2sword 2003-03-24 01:30:23

Option Explicit

Private 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 ProcHwnd As Long '正在处理的窗口句柄
Public ProcGrid As MSHFlexGrid '正在处理的HFlex句柄

Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Public Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, lParam As Any) As Long
Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, lParam As Long) As Long
Dim FaceName As String
'convert the returned string to Unicode
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
'print the form on Form1
FrmSetReport.CmbFont.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
'continue enumeration
EnumFontFamProc = 1
End Function

Public Function HookMe(ByVal FormHwnd As Long, Hgrid As MSHFlexGrid)
Dim VisableRow As Long
Dim LngHeight As Long
Dim I As Long

lpPrevWndProc = SetWindowLong(FormHwnd, GWL_WNDPROC, AddressOf WindowProc)
'获取"控制面板"中的滚动行数值
Call SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, WHEEL_SCROLL_LINES, 0)
'只支持单标头的MSHFLEXGRID
For I = Hgrid.TopRow To Hgrid.Rows - 1
LngHeight = LngHeight + Hgrid.RowHeight(I)
VisableRow = VisableRow + 1 '可见的行数

If LngHeight >= Hgrid.Height - Hgrid.RowHeight(0) Then Exit For
Next
Set ProcGrid = Hgrid
ProcHwnd = FormHwnd
If WHEEL_SCROLL_LINES > VisableRow Then
WHEEL_SCROLL_LINES = VisableRow
End If
End Function

Function WindowProc(ByVal hw As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim pt As POINTL
On Error Resume Next
Select Case uMsg
Case WM_MOUSEWHEEL
Dim wzDelta, wKeys As Integer
wzDelta = HIWORD(wParam)
wKeys = LOWORD(wParam)
pt.x = LOWORD(lParam)
pt.y = HIWORD(lParam)
ScreenToClient ProcHwnd, pt
'滚动明细数据库

'非1时向下滚动
''--------------------------------没有加横滚动，想加的话，在这！！
If Sgn(wzDelta) <> 1 Then

ProcGrid.TopRow = ProcGrid.TopRow + WHEEL_SCROLL_LINES
Else
'移到了顶不能再动
If ProcGrid.TopRow = 1 Then Exit Function
ProcGrid.TopRow = ProcGrid.TopRow - WHEEL_SCROLL_LINES
End If
Case Else
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Select
End Function

Public Sub UnHook(ByVal FormWnd As Long)
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(FormWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

Public Function HIWORD(LongIn As Long) As Integer
' 取出32位值的高16位
HIWORD = (LongIn And &HFFFF0000) \ &H10000
End Function

Public Function LOWORD(LongIn As Long) As Integer
' 取出32位值的低16位
LOWORD = LongIn And &HFFFF&
End Function

...全文