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


 
   
 
'拷贝别人写的代码，是用来在窗体上添加 滚动条的，可是我老是调试不通过，请各位指教。 
 
 
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  
 
 
 
请帮忙！！  
谢谢了

解决方案 »

  1.   

    NewWndProc 函数 必须放到模块中
      

  2.   

    窗体：
    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