Graphic Window scrolling

[Dave Biggs]

This test code was prompted by the discussion at http://www.powerbasic.com/support/pb...ad.php?t=40223

Normally a Graphic Window doesn't have scroll bars but where there's a will...

#Dim All
#Include "win32API.inc"
 
Global hHook???
Function HookGFXWindow(ByVal lMsg As Dword, ByVal wParam As Dword, ByVal lParam As Long) As Long
  If lMsg = %HCBT_CREATEWND Then                    ' wParam = handle of Window about to be created
    UnhookWindowsHookEx hHook
    SetWindowLong wParam, %GWL_STYLE, (GetWindowLong (wParam, %GWL_STYLE) Or %WS_VScroll Or %WS_HScroll)
  End If
 Function = 0
End Function
'------------------/HookGFXWindow
 
Function GWProc(ByVal hWnd As Dword, ByVal wMsg As Dword, _
                ByVal wParam As Dword, ByVal lParam As Long) As Long
 Local  oldProc As Dword
 Static hBmp    As Dword
 Static GW      As Rect
 Static BmpSz, GWSz, siLn As POINTAPI
 Static hsi As SCROLLINFO, vsi As SCROLLINFO
 
  Select Case As Long wMsg
    Case %WM_User + 1000
      GetClientRect hWnd, GW                        ' Get Graphic Window size
      GWSz.x = GW.nRight : GWSz.y = GW.nBottom
      hBmp  = wParam                                ' BitMap Handle and Size (passed from PBMain)
      BmpSz.x = Lo(Word, lParam) : BmpSz.y = Hi(Word, lParam)
 
      siLn.X = 0.1 * GWSz.x ' 10% of page           ' define 'line width' ie move increment
      siLn.Y = 0.1 * GWSz.y ' 10% of page
 
      hsi.cbsize = SizeOf(hsi)
      hsi.nMin   = 0
      hsi.nPage  = GWSz.x
      hsi.fMask  = %SIF_All '%SIF_Range Or %SIF_Page
      hsi.nMax   = BmpSz.x
      SetScrollInfo hWnd, %SB_Horz, hsi, 1          ' initialize Horizontal ScrollInfo structure
 
      vsi = hsi
      vsi.nPage  = GWSz.y
      vsi.nMax   = BmpSz.y
      SetScrollInfo hWnd, %SB_Vert, vsi, 1          ' initialize Vertical ScrollInfo structure
 
      Graphic Attach hWnd, 0
      Graphic Copy hBmp, 0, (hsi.nPos, vsi.nPos)-(hsi.nPos + GWSz.x-1, vsi.nPos + GWSz.y-1) To (0,0)
 
    Case %WM_HScroll
      Select Case Lo(Word, wParam)
        Case %SB_LineLeft   : hsi.nPos = hsi.nPos - siLn.X
        Case %SB_lineright  : hsi.nPos = hsi.nPos + siLn.X
        Case %SB_PageLeft   : hsi.nPos = hsi.nPos - GWSz.x
        Case %SB_PageRight  : hsi.nPos = hsi.nPos + GWSz.x
        Case %SB_Left       : hsi.nPos = 0
        Case %SB_Right      : hsi.nPos = BmpSz.x - GWSz.x
        Case %SB_ThumbTrack : hsi.nPos = Hi(Word, wParam)
        Case Else           : Exit Function
      End Select
      hsi.nPos = Max(hsi.nPos, 0): hsi.nPos = Min(hsi.nPos, BmpSz.x - GWSz.x)
      hsi.fMask = %SIF_Pos
      SetScrollInfo hWnd, %SB_Horz, hsi, 1
 
      Graphic Attach hWnd, 0
      Graphic Copy hBmp, 0, (hsi.nPos, vsi.nPos)-(hsi.nPos + GWSz.x-1, vsi.nPos + GWSz.y-1) To (0,0)
 
    Case %WM_VScroll
      Select Case Lo(Word, wParam)
        Case %SB_LineUp     : vsi.nPos = vsi.nPos - siLn.Y
        Case %SB_LineDown   : vsi.nPos = vsi.nPos + siLn.Y
        Case %SB_PageUp     : vsi.nPos = vsi.nPos - GWSz.y
        Case %SB_PageDown   : vsi.nPos = vsi.nPos + GWSz.y
        Case %SB_ThumbTrack : vsi.nPos = Hi(Word, wParam)
        Case Else           : Exit Function
      End Select
      vsi.nPos = Max(vsi.nPos, 0): vsi.nPos = Min(vsi.nPos, BmpSz.y - GWSz.y)
      vsi.fMask = %SIF_Pos
      SetScrollInfo hWnd, %SB_Vert, vsi, 1
 
      Graphic Attach hWnd, 0
      Graphic Copy hBmp, 0, (hsi.nPos, vsi.nPos)-(hsi.nPos + GWSz.x-1, vsi.nPos + GWSz.y-1) To (0,0)
 
    Case %WM_MouseWheel
     Local zDelta As Integer
      zDelta = Hi(Word, wParam)
 
      If (Lo(Word, wParam) And %MK_CONTROL) = %MK_CONTROL Then  ' horizontal scroll (Ctrl key down)
        If zDelta > 0 Then                                      ' scroll to the left
          SendMessage hWnd, %WM_HScroll, Mak(Long, %SB_LineLeft, 0), 0
        Else                                                    ' scroll to the right
          SendMessage hWnd, %WM_HScroll, Mak(Long, %SB_lineright, 0), 0
        End If
      Else                                                      ' vertical scroll
        If zDelta > 0 Then                                      ' scroll upwards
          SendMessage hWnd, %WM_VScroll, Mak(Long, %SB_LineUp, 0), 0
        Else                                                    ' scroll downwards
          SendMessage hWnd, %WM_VScroll, Mak(Long, %SB_LineDown, 0), 0
        End If
      End If
 
  End Select
 oldProc  = GetProp (hWnd, "OldGWProc")
 Function = CallWindowProc(oldProc, hWnd, wMsg, wParam, lParam)
End Function
'------------------/GWProc
 
Function PBMain() As Long
 Local BmpSz        As PointAPI
 Local hBmp, hGWin  As Dword
 Local xSize&, ySize&, ImageFile$, nFile&, k$
 
  xSize& = 400 : ySize& = 400                       ' Graphic Window size
 
  ImageFile$ = ".\trees.bmp"  ' <<- select an image bigger than the window for scrolling to work.
  nFile& = FreeFile
  Open ImageFile$ For Binary Access Read As nFile&  ' get the size of the image
    Get #nFile&, 19, BmpSz.x
    Get #nFile&, 23, BmpSz.y
  Close nFile&
 
  ' Create a Graphic Bitmap and load the image
  Graphic Bitmap Load ImageFile$, BmpSz.x, BmpSz.y To hBmp
 
  ' create a window to display the part image in the screen (hook it to add scrollbars)
  hHook = SetWindowsHookEx(%WH_CBT, CodePtr(HookGFXWindow), GetModuleHandle(""), 0)
  Graphic Window "Test - Graphic Window scrolling", 200, 200, ySize&, xSize& To hGWin
 
  ' SubClass the GW to get access to scroll info
  SetProp hGWin, "OldGWProc", SetWindowLong(hGWin, %GWL_WNDPROC, CodePtr(GWProc))
 
  ' Pass hBmp and size to GWProc, set up SCROLLINFO structures
  PostMessage hGWin, %WM_User + 1000, hBmp, Mak(Long, BmpSz.x, BmpSz.y)
 
  Graphic Attach hGWin, 0
  Graphic Print "No bitmap loaded"
 
  While IsWin(hGWin)
    Graphic InKey$ To k$                            ' Capture arrow keys etc
    Select Case Len(k$)
      Case 0                                        ' No keys pressed
        Dialog DoEvents
      Case 1                                        ' ASCII Key pressed
        If k$ = $Esc Or k$="q" Or k$="Q" Then
          Exit Loop
        End If
      Case 2                                        ' Extended key pressed - NB not number pad *
       Local vScroll??, hScroll??, wScrollNotify??
        Select Case Asc(Right$(k$,1))
          Case 72 : vScroll = 1 : hScroll = 0 : wScrollNotify = %SB_LineUp    ' Up Arrow
          Case 80 : vScroll = 1 : hScroll = 0 : wScrollNotify = %SB_LineDown  ' Down arrow
          Case 73 : vScroll = 1 : hScroll = 0 : wScrollNotify = %SB_PageUp    ' Page up        *
          Case 81 : vScroll = 1 : hScroll = 0 : wScrollNotify = %SB_PageDown  ' Page down      *
          Case 77 : hScroll = 1 : vScroll = 0 : wScrollNotify = %SB_lineright ' Right arrow
          Case 75 : hScroll = 1 : vScroll = 0 : wScrollNotify = %SB_LineLeft  ' Left arrow
          Case 71 : hScroll = 1 : vScroll = 0 : wScrollNotify = %SB_Left      ' Home           *
          Case 79 : hScroll = 1 : vScroll = 0 : wScrollNotify = %SB_Right     ' End            *
        End Select
        If vScroll Then SendMessage(hGWin, %WM_VScroll, Mak(Long, wScrollNotify, 0), 0)
        If hScroll Then SendMessage(hGWin, %WM_HScroll, Mak(Long, wScrollNotify, 0), 0)
    End Select
  Wend
 
  RemoveProp hGWin, "OldGWroc"
  Graphic Attach hBmp, 0
  Graphic Bitmap End
End Function
'------------------/PBMain

(PS Also a former Seismic Observer / doodle-bugger )