Скроллинг графического поля

' Module1.bas

Option Explicit

Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type

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 GetScrollInfo Lib "user32" (  _
          ByVal hwnd As Long,   _
          ByVal n As Long,   _
          lpScrollInfo As SCROLLINFO) 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 SetWindowPos Lib "user32" (  _
          ByVal hwnd As Long,   _
          ByVal hWndInsertAfter As Long,   _
          ByVal x As Long,   _
          ByVal y As Long,   _
          ByVal cx As Long,   _
          ByVal cy As Long,   _
          ByVal wFlags 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 Declare Function ScrollWindowByNum Lib "user32" Alias "ScrollWindow" (  _
          ByVal hwnd As Long,   _
          ByVal XAmount As Long,   _
          ByVal YAmount As Long,   _
          ByVal lpRect As Long,   _
          ByVal lpClipRect As Long)  As Long

Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOSIZE = &H1
Private Const SB_HORZ = 0
Private Const SB_VERT = 1
Private Const SB_BOTH = 3
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGEUP = 2
Private Const SB_THUMBTRACK = 5

Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
Private Const WM_DESTROY = &H2
Private Const SIF_ALL = &H17

Dim s As SCROLLINFO, OldProc As Long, hObj As Long

Public Sub SetScrollBar(objTarget As Object, sbPos As ScrollBarConstants)
  Dim lStyle As Long
  If hObj <> 0 Then Exit Sub
  On Error Resume Next
  hObj = objTarget.hwnd
  If Err Then
     MsgBox "Can not set scrollbars on this object!", vbCritical
     Exit Sub
  End If
  On Error GoTo 0
  lStyle = sbPos * &H100000
  SetWindowLong hObj, GWL_STYLE, GetWindowLong(hObj, GWL_STYLE) Or lStyle
  SetWindowPos hObj, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE
  s.cbSize = Len(s)
  s.fMask = SIF_ALL
  s.nMin = 0
  s.nPos = 0
  If (sbPos And vbVertical) = vbVertical Then
     s.nMax = objTarget.Height \ Screen.TwipsPerPixelY
     s.nPage = s.nMax \ 10
     Call SetScrollInfo(hObj, SB_VERT, s, True)
  End If
  If (sbPos And vbHorizontal) = vbHorizontal Then
     s.nMax = objTarget.Width \ Screen.TwipsPerPixelX
     s.nPage = s.nMax \ 10
     Call SetScrollInfo(hObj, SB_HORZ, s, True)
  End If
  OldProc = SetWindowLong(hObj, GWL_WNDPROC, AddressOf WndProc)
End Sub

Public Function WndProc(ByVal hOwner As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim nOldPos As Long
   Select Case wMsg
      Case WM_VSCROLL, WM_HSCROLL
           GetScrollInfo hOwner, wMsg - WM_HSCROLL, s
           nOldPos = s.nPos
           Select Case GetLoWord(wParam)
               Case SB_LINEDOWN
                    s.nPos = s.nPos + 1
               Case SB_LINEUP
                    s.nPos = s.nPos - 1
               Case SB_PAGEDOWN
                    s.nPos = s.nPos + s.nPage
               Case SB_PAGEUP
                    s.nPos = s.nPos - s.nPage
               Case SB_THUMBTRACK
                    s.nPos = GetHiWord(wParam)
           End Select
           If s.nPos < s.nMin Then s.nPos = s.nMin
           If s.nPos > s.nMax Then s.nPos = s.nMax
           SetScrollInfo hOwner, wMsg - WM_HSCROLL, s, True
           If wMsg = WM_VSCROLL Then
              ScrollWindowByNum hOwner, 0, nOldPos - s.nPos, 0, 0
           Else
              ScrollWindowByNum hOwner, nOldPos - s.nPos, 0, 0, 0
           End If
      Case WM_DESTROY
           If hObj <> 0 Then Call SetWindowLong(hObj, GWL_WNDPROC, OldProc)
      Case Else
   End Select
   WndProc = CallWindowProc(OldProc, hOwner, wMsg, wParam, lParam)
End Function

Private Function GetHiWord(dw As Long) As Long
  If dw And &H80000000 Then
     GetHiWord = (dw \ 65535) - 1
  Else
     GetHiWord = dw \ 65535
  End If
End Function

Private Function GetLoWord(dw As Long) As Long
   If dw And &H8000& Then
      GetLoWord = &H8000 Or (dw And &H7FFF&)
   Else
      GetLoWord = dw And &HFFFF&
   End If
End Function


'Form1.frm
' Поместите на форму PictureBox

Option Explicit

Private Sub Form_Load()
   SetScrollBar Me, vbBoth
'или   SetScrollBar Picture1, vbVertical

End Sub