在窗体上添加滚动条的代码,请帮助调试?

flc 2003-11-20 09:12:40




'拷贝别人写的代码,是用来在窗体上添加 滚动条的,可是我老是调试不通过,请各位指教。


Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)

'WM_HSCROLL和WM_VSCROLL指出了滚动条位置消息,却仅提供了16位数据,
'而函数SetScrollnfo和GetScrollnfo则提供了32位的滚动条数据。
Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long
Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
Private Declare Function GetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, lpMinPos As Long, lpMaxPos As Long) As Long
Private Declare Function SetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpcScrollInfo As SCROLLINFO, ByVal bool As Boolean) As Long
Private Declare Function SetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
Private Declare Function SetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal bRedraw As Long) As Long
Private Type SCROLLINFO
cbSize As Long
nPos As Long
nTrackPos As Long
nMax As Long
nPage As Long
nMin As Long
fMask As Long
End Type
Private Const SB_BOTTOM = 7
Private Const SB_TOP = 6
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGEUP = 2
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_VERT = 1

Private Const SB_RIGHT = 7
Private Const SB_LEFT = 6
Private Const SB_PAGERIGHT = 3
Private Const SB_PAGELEFT = 2
Private Const SB_LINERIGHT = 1
Private Const SB_LINELEFT = 0
Private Const SB_HORZ = 0

Private Const SB_THUMBTRACK = 5
Private Const SB_THUMBPOSITION = 4
Private Const SB_ENDSCROLL = 8

Public lPrevWndProc As Long

Public Function NewWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case WM_VSCROLL ', WM_HSCROLL
Dim lPostion As Long
lPostion = GetScrollPos(hwnd, SB_VERT)
Select Case (wParam Mod &H10000) 'wParam的低字节
Case SB_LINEDOWN '单击向下箭头
lPostion = lPostion + 1
Case SB_LINEUP '单击向上箭头
lPostion = lPostion - 1
Case SB_PAGEDOWN '单击滚动块与向下箭头之间部分
lPostion = lPostion + 10
Case SB_PAGEUP '单击滚动块与向上箭头之间部分
lPostion = lPostion - 10
Case SB_BOTTOM '滚动块到达向下箭头,最大值
lPostion = 0
Case SB_TOP '滚动块到达向上箭头,最小值
lPostion = 100
Case SB_THUMBPOSITION '拖动滚动块结束,wParam的高字节为滚动块所在位置
lPostion = wParam \ &H10000
Case SB_THUMBTRACK '正在拖动滚动块,wParam的高字节为滚动块所在位置
SetWindowText hwnd, wParam \ &H10000
End Select
If lPostion < 0 Then lPostion = 0
If lPostion > 100 Then lPostion = 100
SetScrollPos hwnd, SB_VERT, lPostion, True
Case Else
NewWndProc = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)
End Select
End Function


Option Explicit

Private Sub Form_Load()
Dim lOldWndStyle As Long
lOldWndStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
SetWindowLong Me.hwnd, GWL_STYLE, lOldWndStyle Or WS_VSCROLL 'Or WS_HSCROLL
lPrevWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf NewWndProc)‘在此处抱错:操作符Addressof使用无效。
End Sub

Private Sub Form_Unload(Cancel As Integer)
SetWindowLong Me.hwnd, GWL_WNDPROC, lPrevWndProc
End Sub



请帮忙!!
谢谢了
...全文
63 4 打赏 收藏 转发到动态 举报
写回复
用AI写文章
4 条回复
切换为时间正序
请发表友善的回复…
发表回复
flc 2003-11-21
  • 打赏
  • 举报
回复
谢谢了各位
rainstormmaster 2003-11-21
  • 打赏
  • 举报
回复
窗体:
Option Explicit

Private Sub Form_Load()
Dim lOldWndStyle As Long
lOldWndStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
SetWindowLong Me.hwnd, GWL_STYLE, lOldWndStyle Or WS_VSCROLL 'Or WS_HSCROLL
lPrevWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf NewWndProc)‘在此处抱错:操作符Addressof使用无效。
End Sub

Private Sub Form_Unload(Cancel As Integer)
SetWindowLong Me.hwnd, GWL_WNDPROC, lPrevWndProc
End Sub


模块:
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex 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 WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)

'WM_HSCROLL和WM_VSCROLL指出了滚动条位置消息,却仅提供了16位数据,
'而函数SetScrollnfo和GetScrollnfo则提供了32位的滚动条数据。
Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long
Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
Private Declare Function GetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, lpMinPos As Long, lpMaxPos As Long) As Long
Private Declare Function SetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpcScrollInfo As SCROLLINFO, ByVal bool As Boolean) As Long
Private Declare Function SetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
Private Declare Function SetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal bRedraw As Long) As Long
Private Type SCROLLINFO
cbSize As Long
nPos As Long
nTrackPos As Long
nMax As Long
nPage As Long
nMin As Long
fMask As Long
End Type
Private Const SB_BOTTOM = 7
Private Const SB_TOP = 6
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGEUP = 2
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_VERT = 1

Private Const SB_RIGHT = 7
Private Const SB_LEFT = 6
Private Const SB_PAGERIGHT = 3
Private Const SB_PAGELEFT = 2
Private Const SB_LINERIGHT = 1
Private Const SB_LINELEFT = 0
Private Const SB_HORZ = 0

Private Const SB_THUMBTRACK = 5
Private Const SB_THUMBPOSITION = 4
Private Const SB_ENDSCROLL = 8

Public lPrevWndProc As Long

Public Function NewWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case WM_VSCROLL ', WM_HSCROLL
Dim lPostion As Long
lPostion = GetScrollPos(hwnd, SB_VERT)
Select Case (wParam Mod &H10000) 'wParam的低字节
Case SB_LINEDOWN '单击向下箭头
lPostion = lPostion + 1
Case SB_LINEUP '单击向上箭头
lPostion = lPostion - 1
Case SB_PAGEDOWN '单击滚动块与向下箭头之间部分
lPostion = lPostion + 10
Case SB_PAGEUP '单击滚动块与向上箭头之间部分
lPostion = lPostion - 10
Case SB_BOTTOM '滚动块到达向下箭头,最大值
lPostion = 0
Case SB_TOP '滚动块到达向上箭头,最小值
lPostion = 100
Case SB_THUMBPOSITION '拖动滚动块结束,wParam的高字节为滚动块所在位置
lPostion = wParam \ &H10000
Case SB_THUMBTRACK '正在拖动滚动块,wParam的高字节为滚动块所在位置
SetWindowText hwnd, wParam \ &H10000
End Select
If lPostion < 0 Then lPostion = 0
If lPostion > 100 Then lPostion = 100
SetScrollPos hwnd, SB_VERT, lPostion, True
Case Else
NewWndProc = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)
End Select
End Function
hxy1982 2003-11-21
  • 打赏
  • 举报
回复
up
pigsanddogs 2003-11-20
  • 打赏
  • 举报
回复
NewWndProc 函数 必须放到模块中

7,763

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧