GFPictureScroll/GFPictureScroll.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   7335
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7275
   LinkTopic       =   "Form1"
   ScaleHeight     =   7335
   ScaleWidth      =   7275
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.PictureBox ScrollSourcePicture
      AutoRedraw      =   ‑1 'True
      AutoSize        =   ‑1 'True
      Height          =   5310
      Left            =   120
      Picture         =   "GFPictureScroll.frx":0000
      ScaleHeight     =   5250
      ScaleWidth      =   6975
      TabIndex        =   3
      Top             =   1920
      Width           =   7035
   End
   Begin VB.VScrollBar VScroll1
      Height          =   1515
      Left            =   3180
      TabIndex        =   2
      Top             =   120
      Width           =   195
   End
   Begin VB.HScrollBar HScroll1
      Height          =   195
      Left            =   120
      TabIndex        =   1
      Top             =   1680
      Width           =   3015
   End
   Begin VB.PictureBox ScrollTargetPicture
      AutoRedraw      =   ‑1 'True
      Height          =   1515
      Left            =   120
      ScaleHeight     =   1455
      ScaleWidth      =   2955
      TabIndex        =   0
      Top             =   120
      Width           =   3015
   End
   Begin VB.Label Label1
      Caption         =   "Picture (c) www.vacher.com"
      Height          =   195
      Left            =   3480
      TabIndex        =   4
      Top             =   1680
      Width           =   3675
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2004 by Louis. Demonstration how one can scroll a picture.
'Downloadable via Louis Coder's Code Section, www.louis‑coder.com.
'
'NOTE: make prefix 'Scroll' fit to the meaning in the target project.
'
'Scroll
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'Scroll
Dim ScrollXPos As Long 'can be renamed
Dim ScrollYPos As Long 'can be renamed

Private Sub Form_Load()
    'on error resume next
    Call ScrollScrollBars_Update(ScrollXPos, ScrollYPos, ScrollSourcePicture, ScrollTargetPicture)
    Call HScroll1_Scroll
End Sub

Private Sub ScrollScrollBars_Update(ByVal ScrollXPos As Long, ByVal ScrollYPos As Long, ByRef ScrollSourcePicture As PictureBox, ByRef ScrollTargetPicture As PictureBox)
    'On Error Resume Next
    Dim ScrollSourcePictureScaleModeUnchanged As Integer
    Dim ScrollTargetPictureScaleModeUnchanged As Integer
    'preset
    ScrollSourcePictureScaleModeUnchanged = ScrollSourcePicture.ScaleMode
    ScrollSourcePicture.ScaleMode = vbPixels 'important
    ScrollTargetPictureScaleModeUnchanged = ScrollTargetPicture.ScaleMode
    ScrollTargetPicture.ScaleMode = vbPixels 'important
    'begin
    With HScroll1
        .Min = 0
        .Max = (ScrollSourcePicture.ScaleWidth ‑ ScrollTargetPicture.ScaleWidth)
        .TabStop = False 'avoid blinking slider (looks ugly)
        .LargeChange = ScrollTargetPicture.ScaleWidth
        .SmallChange = ScrollTargetPicture.ScaleWidth / 10
        .Value = Abs(ScrollXPos)
    End With
    With VScroll1 'viva Strg‑C‑Strg‑V!
        .Min = 0
        .Max = (ScrollSourcePicture.ScaleHeight ‑ ScrollTargetPicture.ScaleHeight)
        .TabStop = False 'avoid blinking slider (looks ugly)
        .LargeChange = ScrollTargetPicture.ScaleHeight
        .SmallChange = ScrollTargetPicture.ScaleHeight / 10
        .Value = Abs(ScrollYPos)
    End With
    'display changes
    HScroll1.Refresh
    VScroll1.Refresh
    'reset
    ScrollSourcePicture.ScaleMode = ScrollSourcePictureScaleModeUnchanged
    ScrollTargetPicture.ScaleMode = ScrollTargetPictureScaleModeUnchanged
End Sub

Private Sub HScroll1_Scroll()
    'on error resume next 'called when slider is grabbed and moved
    Call HScroll1_Change
    'DoEvents 'only if program system allows
End Sub

Private Sub HScroll1_Change()
    'on error resume next
    ScrollXPos = ‑Abs(HScroll1.Value)
    ScrollYPos = ‑Abs(VScroll1.Value)
    'display changes
    Call ScrollTargetPicture_RefreshSub(ScrollXPos, ScrollYPos)
End Sub

Private Sub VScroll1_Scroll()
    'on error resume next 'called when slider is grabbed and moved
    Call VScroll1_Change
    'DoEvents 'only if program system allows
End Sub

Private Sub VScroll1_Change()
    'on error resume next
    ScrollXPos = ‑Abs(HScroll1.Value)
    ScrollYPos = ‑Abs(VScroll1.Value)
    'display changes
    Call ScrollTargetPicture_RefreshSub(ScrollXPos, ScrollYPos)
End Sub

Private Sub ScrollTargetPicture_RefreshSub(ByVal ScrollXPos As Long, ByVal ScrollYPos As Long)
    'on error resume next
    Dim ScrollTargetPictureScaleModeUnchanged As Integer
    ScrollTargetPictureScaleModeUnchanged = ScrollTargetPicture.ScaleMode
    ScrollTargetPicture.ScaleMode = vbPixels 'important
    ScrollTargetPicture.Cls 'reset
    Call BitBlt(ScrollTargetPicture.hDC, 0, 0, ScrollTargetPicture.ScaleWidth, ScrollTargetPicture.ScaleHeight, _
        ScrollSourcePicture.hDC, Abs(ScrollXPos), Abs(ScrollYPos), vbSrcCopy)
    ScrollTargetPicture.ScaleMode = ScrollTargetPictureScaleModeUnchanged 'reset
End Sub


[END OF FILE]