home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 13 / CDA13.ISO / cdactual / demobin / share / program / VBasic / SCRL_CJ.ZIP / SCROLL.BAS < prev    next >
Encoding:
BASIC Source File  |  1993-09-11  |  6.6 KB  |  226 lines

  1. ' Scroll.Bas:
  2. ' Coded by Christian Jⁿrges on September 93
  3.  
  4. Option Explicit
  5.  
  6. Declare Sub SetScrollRange Lib "User" (ByVal hWnd As Integer, ByVal nBar As Integer, ByVal nMinPos As Integer, ByVal nMaxPos As Integer, ByVal bRedraw As Integer)
  7. Declare Function SetScrollPos Lib "User" (ByVal hWnd As Integer, ByVal nBar As Integer, ByVal nPos As Integer, ByVal bRedraw As Integer) As Integer
  8.  
  9. Global Const SB_HORZ = 0
  10. Global Const SB_VERT = 1
  11. Global Const SB_BOTH = 3
  12.  
  13. Global Const WM_VSCROLL = &H115
  14. Global Const WM_HSCROLL = &H114
  15. Global Const SB_BOTTOM = 7
  16. Global Const SB_ENDSCROLL = 8
  17. Global Const SB_LINEDOWN = 1
  18. Global Const SB_LINEUP = 0
  19. Global Const SB_PAGEDOWN = 3
  20. Global Const SB_PAGEUP = 2
  21. Global Const SB_THUMBPOSITION = 4
  22. Global Const SB_THUMBTRACK = 5
  23. Global Const SB_TOP = 6
  24.  
  25.  
  26. Type Rect
  27.     Left As Integer
  28.     Top As Integer
  29.     Right As Integer
  30.     Bottom As Integer
  31. End Type
  32.  
  33. Declare Sub GetClientRect Lib "User" (ByVal hWnd As Integer, lpRect As Rect)
  34.  
  35. ' Set Pixel for each horizonatal and vertical scrolling
  36.  
  37. Const ScrollSteps = 12
  38.  
  39.  
  40.  
  41. Dim Shared iThumbTrack As Integer
  42.  
  43. Sub EnableThumbTrack (iBoolean)
  44.  
  45.     ' You can also modify iThumbTrack directly....
  46.     
  47.     If iBoolean Then
  48.         iThumbTrack = True
  49.     Else
  50.         iThumbTrack = False
  51.     End If
  52.  
  53. End Sub
  54.  
  55. Sub InitScrollPic (PicBox As PictureBox)
  56.  
  57.     PicBox.Top = 0 ' Set Picture to upper left corner
  58.     PicBox.Left = 0
  59.     
  60. End Sub
  61.  
  62. Sub Scroll (FormHandle As Form, PicHandle As PictureBox, iMsg As Integer, iwParam As Integer, lParam As Long)
  63.  
  64. If iMsg <> WM_VSCROLL And iMsg <> WM_HSCROLL Then Exit Sub
  65.  
  66. Dim FormRect As Rect
  67. Dim iPicTop As Long
  68. Dim iPicHeight As Long
  69. Dim iPicLeft As Long
  70. Dim iPicWidth As Long
  71. Dim iPicVPos As Long
  72. Dim iPicHPos As Long
  73. Dim iOldFormMode As Integer
  74. Dim iOldPicMode As Integer
  75. Dim iOldThumbPos As Integer
  76. Dim iFormHeight As Integer
  77.  
  78.     iOldFormMode = FormHandle.ScaleMode
  79.     iOldPicMode = PicHandle.ScaleMode
  80.     FormHandle.ScaleMode = 3
  81.     PicHandle.ScaleMode = 3
  82.     GetClientRect FormHandle.hWnd, FormRect
  83.     
  84.     ' Test horizontal or vertical scrollbar...
  85.     
  86.     If iMsg = WM_VSCROLL Then
  87.         iPicTop = PicHandle.Top
  88.         iPicHeight = PicHandle.Height
  89.         iFormHeight = FormRect.Bottom
  90.     Else
  91.         iPicTop = PicHandle.Left
  92.         iPicHeight = PicHandle.Width
  93.         iFormHeight = FormRect.Right
  94.     End If
  95.     
  96.     ' Only one algorithm is needed for both scrollbars
  97.     
  98.     iPicVPos = iPicTop + iPicHeight
  99.     Select Case iwParam
  100.         Case SB_LINEUP
  101.             iPicTop = iPicTop + ScrollSteps
  102.         Case SB_LINEDOWN
  103.             iPicTop = iPicTop - ScrollSteps
  104.         Case SB_PAGEDOWN
  105.             iPicTop = iPicTop - iFormHeight
  106.         Case SB_PAGEUP
  107.             iPicTop = iPicTop + iFormHeight
  108.         Case SB_THUMBPOSITION
  109.             If Not iThumbTrack Then iPicTop = -lParam
  110.         Case SB_THUMBTRACK
  111.             If iThumbTrack Then iPicTop = -lParam
  112.  
  113.     End Select
  114.     
  115.     ' Are we still inside the picture range ?
  116.     ' If not, correct position
  117.     
  118.     If iPicTop + iPicHeight < iFormHeight Then iPicTop = iFormHeight - iPicHeight
  119.     If iPicTop + iPicHeight > iPicHeight Then iPicTop = 0
  120.     
  121.     ' Now decide again, which scrollbar to handle (sorry for bad english...)
  122.  
  123.     If iMsg = WM_VSCROLL Then
  124.         PicHandle.Top = iPicTop ' Set new picture position
  125.         If iwParam <> SB_ENDSCROLL Then
  126.             iOldThumbPos = SetScrollPos(FormHandle.hWnd, SB_VERT, Abs(PicHandle.Top), True)
  127.         Else
  128.             SetScrollBar FormHandle, PicHandle
  129.         End If
  130.     Else
  131.         PicHandle.Left = iPicTop
  132.         If iwParam <> SB_ENDSCROLL Then
  133.             iOldThumbPos = SetScrollPos(FormHandle.hWnd, SB_HORZ, Abs(PicHandle.Left), True)
  134.         Else
  135.             SetScrollBar FormHandle, PicHandle
  136.         End If
  137.      End If
  138.      
  139.     FormHandle.ScaleMode = iOldFormMode
  140.     PicHandle.ScaleMode = iOldPicMode
  141.     
  142. End Sub
  143.  
  144. Sub SetScrollBar (FormHandle As Form, PicHandle As PictureBox)
  145.  
  146.  
  147. Static bWhileSet As Integer
  148. Dim iFormH As Integer
  149. Dim iFormW As Integer
  150. Dim iPicH As Integer
  151. Dim iPicW As Integer
  152. Dim iScrollMode As Integer
  153. Dim FormRect As Rect
  154. Dim iVertMin As Integer
  155. Dim iVertMax As Integer
  156. Dim iHorzMin As Integer
  157. Dim iHorzMax As Integer
  158. Dim iOldThumbPos
  159. Dim iOldFormMode As Integer
  160. Dim iOldPicMode As Integer
  161.  
  162.  
  163. If Not bWhileSet Then ' this prevents stack overflow
  164.     bWhileSet = True
  165.     iOldFormMode = FormHandle.ScaleMode
  166.     iOldPicMode = PicHandle.ScaleMode
  167.     ' We need Pixel, because GetClientRect returns in Pixel !
  168.     FormHandle.ScaleMode = 3
  169.     PicHandle.ScaleMode = 3
  170.  
  171.     iPicW = PicHandle.Width
  172.     iPicH = PicHandle.Height
  173.     
  174.     
  175.     iHorzMin = PicHandle.Left
  176.     iHorzMax = iHorzMin + iPicW - FormRect.Bottom
  177.     iVertMin = PicHandle.Top
  178.     iVertMax = iVertMin + iPicH - FormRect.Left
  179.  
  180.     GetClientRect FormHandle.hWnd, FormRect ' Get the client size of the window
  181.     
  182.     iFormH = FormRect.Bottom
  183.     iFormW = FormRect.Right
  184.     
  185.     iScrollMode = 0
  186.     
  187.     ' find out if the Picture-Box is bigger then the Window,
  188.     ' or if Picture is still in negativ range...
  189.     
  190.     If iPicH >= iFormH Or iVertMin < 0 Then iScrollMode = 1
  191.     If iPicW >= iFormW Or iHorzMin < 0 Then iScrollMode = iScrollMode + 2
  192.  
  193.     Select Case iScrollMode
  194.         Case 1
  195.             ' show only vertical scrollbar
  196.             SetScrollRange FormHandle.hWnd, SB_VERT, 0, iPicH - iFormH, False
  197.             iOldThumbPos = SetScrollPos(FormHandle.hWnd, SB_VERT, Abs(iVertMin), True)
  198.             SetScrollRange FormHandle.hWnd, SB_HORZ, 0, 0, False
  199.             
  200.         Case 2
  201.             ' show only horizontal scrollbar
  202.             SetScrollRange FormHandle.hWnd, SB_VERT, 0, 0, False
  203.             SetScrollRange FormHandle.hWnd, SB_HORZ, 0, iPicW - iFormW, False
  204.             iOldThumbPos = SetScrollPos(FormHandle.hWnd, SB_HORZ, Abs(iHorzMin), True)
  205.             
  206.         Case 3
  207.             ' show both scrollbars
  208.             SetScrollRange FormHandle.hWnd, SB_HORZ, 0, iPicW - iFormW, False
  209.             iOldThumbPos = SetScrollPos(FormHandle.hWnd, SB_HORZ, Abs(iHorzMin), True)
  210.             SetScrollRange FormHandle.hWnd, SB_VERT, 0, iPicH - iFormH, False
  211.             iOldThumbPos = SetScrollPos(FormHandle.hWnd, SB_VERT, Abs(iVertMin), True)
  212.             
  213.         Case Else
  214.             ' hide both scrollbars
  215.             SetScrollRange FormHandle.hWnd, SB_VERT, 0, 0, False
  216.             SetScrollRange FormHandle.hWnd, SB_HORZ, 0, 0, False
  217.             
  218.     End Select
  219.     FormHandle.ScaleMode = iOldFormMode
  220.     PicHandle.ScaleMode = iOldPicMode
  221.     bWhileSet = False
  222. End If
  223.  
  224. End Sub
  225.  
  226.