vbAccelerator - Contents of code file: fTest.frm

VERSION 5.00
Object = "{2160ABB2-9DC4-11D2-8E21-E8F105C10000}#5.0#0"; "vbalscrb.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmTestScrollButtons 
   Caption         =   "Scroll With Buttons Control Tester"
   ClientHeight    =   3945
   ClientLeft      =   3255
   ClientTop       =   2205
   ClientWidth     =   10200
   Icon            =   "fTest.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3945
   ScaleWidth      =   10200
   Begin VB.TextBox txtProps 
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3615
      Left            =   60
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      TabIndex        =   4
      Top             =   120
      Visible         =   0   'False
      Width           =   1635
   End
   Begin VB.PictureBox picTest 
      BorderStyle     =   0  'None
      Height          =   3435
      Left            =   1740
      ScaleHeight     =   3435
      ScaleWidth      =   4995
      TabIndex        =   0
      Top             =   120
      Width           =   4995
      Begin VB.PictureBox picImage 
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         Height          =   9060
         Left            =   900
         Picture         =   "fTest.frx":1272
         ScaleHeight     =   9000
         ScaleWidth      =   3390
         TabIndex        =   5
         Top             =   180
         Visible         =   0   'False
         Width           =   3450
      End
      Begin vbalScrollButtons.vbalScrollButtonCtl sbrSize 
         Height          =   315
         Left            =   4620
         TabIndex        =   1
         Top             =   2580
         Width           =   255
         _ExtentX        =   450
         _ExtentY        =   556
         ScrollType      =   2
      End
      Begin vbalScrollButtons.vbalScrollButtonCtl hscScroll 
         Height          =   315
         Left            =   60
         TabIndex        =   2
         Top             =   2580
         Width           =   4455
         _ExtentX        =   7858
         _ExtentY        =   556
      End
      Begin vbalScrollButtons.vbalScrollButtonCtl vscScroll 
         Height          =   2235
         Left            =   4500
         TabIndex        =   3
         Top             =   240
         Width           =   375
         _ExtentX        =   10610
         _ExtentY        =   556
         ScrollType      =   1
      End
   End
   Begin ComctlLib.ImageList ilsIcons 
      Left            =   7380
      Top             =   180
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   8421376
      ImageWidth      =   10
      ImageHeight     =   10
      MaskColor       =   8421376
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} 
         NumListImages   =   6
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "fTest.frx":5BCA
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "fTest.frx":5CAC
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "fTest.frx":5D8E
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "fTest.frx":5E70
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "fTest.frx":5F52
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "fTest.frx":6034
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnuFileTOP 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "&Open..."
         Index           =   0
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuFile 
         Caption         =   "P&roperties"
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuFile 
         Caption         =   "E&xit"
         Index           =   4
      End
   End
   Begin VB.Menu mnuViewTop 
      Caption         =   "&View"
      Begin VB.Menu mnuView 
         Caption         =   "&Stretch"
         Index           =   0
      End
      Begin VB.Menu mnuView 
         Caption         =   "&Zoom"
         Index           =   1
         Begin VB.Menu mnuZoom 
            Caption         =   "1:10"
            Index           =   0
         End
      End
   End
End
Attribute VB_Name = "frmTestScrollButtons"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As
 Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Type RECT
   Left As Long
   TOp As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function GetSysColorBrush Lib "USER32" (ByVal nIndex As Long)
 As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function GetClientRect Lib "USER32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private m_fZoom As Single
Private m_lWidth As Long
Private m_lheight As Long

Private Sub Zoom(ByVal iDir As Long)
Dim l As Long
Dim lSelIndex As Integer
   For l = mnuZoom.LBound To mnuZoom.UBound
      If (mnuZoom(l).Checked) Then
         lSelIndex = l
         Exit For
      End If
   Next l

   lSelIndex = lSelIndex + iDir
   If (lSelIndex > mnuZoom.UBound) Then
      lSelIndex = mnuZoom.UBound
   ElseIf (lSelIndex < mnuZoom.LBound) Then
      lSelIndex = mnuZoom.LBound
   End If
   mnuZoom_Click lSelIndex

End Sub

Private Sub Render()
Dim lWidth As Long, lheight As Long
Dim lImageWidth As Long, lImageHeight As Long
Dim lMissingWidth As Long, lMissingHeight As Long
Dim xSrc As Long, ySrc As Long, xDst As Long, yDst As Long
Dim lSrcWidth As Long, lSrcHeight As Long
Dim tR As RECT, tTR As RECT, hBr As Long

   lWidth = (picTest.ScaleWidth) \ Screen.TwipsPerPixelX
   lheight = (picTest.ScaleHeight) \ Screen.TwipsPerPixelX
   
   ' Enable scroll/set min and max:
   If Not (mnuView(0).Checked) Then
                  
      ' Stretch as required:
      If (m_fZoom >= 1) Then
         xSrc = hscScroll.Value / m_fZoom
         ySrc = vscScroll.Value / m_fZoom
         lSrcWidth = lWidth / m_fZoom
         lSrcHeight = lheight / m_fZoom
         StretchBlt picTest.hdc, xDst, yDst, lWidth, lheight, picImage.hdc,
          xSrc, ySrc, lSrcWidth, lSrcHeight, vbSrcCopy
      Else
         xSrc = hscScroll.Value
         ySrc = vscScroll.Value
         lWidth = m_lWidth * m_fZoom
         lheight = m_lheight * m_fZoom
         lSrcWidth = m_lWidth
         lSrcHeight = m_lheight
         StretchBlt picTest.hdc, xDst, yDst, lWidth, lheight, picImage.hdc,
          xSrc, ySrc, lSrcWidth, lSrcHeight, vbSrcCopy
      End If
      
      ' Fill space:
      GetClientRect picTest.hwnd, tR
      hBr = GetSysColorBrush(vbButtonFace And &H1F&)
      If (lWidth < m_lWidth * m_fZoom) Then
         LSet tTR = tR
         'Debug.Print tTR.Left, tTR.TOp, tTR.Right, tTR.Bottom
         tTR.Left = m_lWidth * m_fZoom
         FillRect picTest.hdc, tTR, hBr
      End If
      If (lheight < m_lheight * m_fZoom) Then
         LSet tTR = tR
         tTR.TOp = m_lheight * m_fZoom
         FillRect picTest.hdc, tTR, hBr
      End If
      DeleteObject hBr

   Else
      
      ' stretch to fit:
      StretchBlt picTest.hdc, 0, 0, lWidth, lheight, picImage.hdc, 0, 0,
       m_lWidth, m_lheight, vbSrcCopy
      
   End If
   
   
End Sub
Private Sub SetScroll()
Dim lImageWidth As Long, lImageHeight As Long
Dim lMissingWidth As Long, lMissingHeight As Long
Dim lWidth As Long, lheight As Long
Dim lProportion As Long

   If Not (mnuView(0).Checked) Then
      lWidth = (picTest.ScaleWidth) \ Screen.TwipsPerPixelX
      lheight = (picTest.ScaleHeight) \ Screen.TwipsPerPixelX
      lImageWidth = m_lWidth * m_fZoom
      lImageHeight = m_lheight * m_fZoom
      lMissingWidth = lImageWidth - lWidth
      If (lMissingWidth <= 0) Then
         hscScroll.Value = 0
         hscScroll.ScrollEnabled = False
      Else
         hscScroll.Max = lMissingWidth
         lProportion = lMissingWidth \ lWidth + 1
         hscScroll.LargeChange = hscScroll.Max \ lProportion
      End If
      lMissingHeight = lImageHeight - lheight
      If (lMissingHeight <= 0) Then
         vscScroll.Value = 0
         vscScroll.ScrollEnabled = False
         vscScroll.ButtonEnabled("pageup") = False
         vscScroll.ButtonEnabled("pagedown") = False
      Else
         vscScroll.ButtonEnabled("pageup") = True
         vscScroll.ButtonEnabled("pagedown") = True
         vscScroll.Max = lMissingHeight
         lProportion = lMissingHeight \ lheight + 1
         vscScroll.LargeChange = vscScroll.Max \ lProportion
      End If
   Else
      vscScroll.ScrollEnabled = False
      hscScroll.ScrollEnabled = False
   End If
End Sub

Private Sub Form_Load()
Dim i As Long

   With hscScroll
      .ImageList = ilsIcons
      .XpStyleButtons = True
      .AddButton "props", "Show Properties", 0, 0, esbcButtonPositionLeftTop,
       True
      .AddButton "stretch", "Stretch To Fit", 1, 1, esbcButtonPositionLeftTop,
       True
      .AddButton "zoomin", "Zoom In", 3, 3, esbcButtonPositionRightBottom
      .AddButton "zoomout", "Zoom Out", 2, 2, esbcButtonPositionRightBottom
   End With
   With vscScroll
      .ImageList = ilsIcons
      .XpStyleButtons = True
      .AddButton "pageup", "Page Up", 4, 4, esbcButtonPositionLeftTop
      .AddButton "zoomin", "Zoom In", 3, 3, esbcButtonPositionRightBottom
      .AddButton "zoomout", "Zoom Out", 2, 2, esbcButtonPositionRightBottom
      .AddButton "pagedown", "Page Down", 5, 5, esbcButtonPositionRightBottom
   End With
   
   ' Add zoom options:
   For i = 10 To 1 Step -1
      If (i < 10) Then
         Load mnuZoom(mnuZoom.UBound + 1)
      End If
      With mnuZoom(mnuZoom.UBound)
         .Visible = True
         .Caption = "1:" & i
         .Tag = 1 / i
         If (i = 1) Then
            .Checked = True
         End If
      End With
   Next i
   For i = 2 To 10
      Load mnuZoom(mnuZoom.UBound + 1)
      With mnuZoom(mnuZoom.UBound)
         .Visible = True
         .Caption = i & ":1"
         .Tag = i
      End With
   Next i
   
   m_lWidth = picImage.ScaleWidth \ Screen.TwipsPerPixelX
   m_lheight = picImage.ScaleHeight \ Screen.TwipsPerPixelY
   m_fZoom = 1
   SetScroll
   
End Sub

Private Sub Form_Paint()
   Render
End Sub

Private Sub Form_Resize()
Dim lLeft As Long
   If (txtProps.Visible) Then
      lLeft = txtProps.Width + 4 * Screen.TwipsPerPixelX
      txtProps.Move 2 * Screen.TwipsPerPixelX, 2 * Screen.TwipsPerPixelY,
       txtProps.Width, Me.ScaleHeight - 4 * Screen.TwipsPerPixelY
   Else
      lLeft = 2 * Screen.TwipsPerPixelX
   End If
   
   picTest.Move lLeft, 2 * Screen.TwipsPerPixelY, Me.ScaleWidth - lLeft - 2 *
    Screen.TwipsPerPixelX, Me.ScaleHeight - 4 * Screen.TwipsPerPixelY
End Sub

Private Sub hscScroll_ButtonClick(ByVal lButton As Long)
Dim i As Long
Dim bS As Boolean

   Select Case hscScroll.ButtonKey(lButton)
   Case "props"
      txtProps.Visible = (hscScroll.ButtonValue("props") = Checked)
      mnuFile(2).Checked = (txtProps.Visible)
      Form_Resize
   Case "stretch"
      bS = (hscScroll.ButtonValue("stretch") = Unchecked)
      mnuView(0).Checked = Not (bS)
      mnuView(1).Enabled = bS
      hscScroll.ScrollEnabled = bS
      hscScroll.ButtonEnabled("zoomin") = bS
      hscScroll.ButtonEnabled("zoomout") = bS
      vscScroll.ScrollEnabled = bS
      For i = 1 To vscScroll.ButtonCount
         vscScroll.ButtonEnabled(i) = bS
      Next i
      SetScroll
      picTest.Refresh
   
   ' here we're just stretching in both directions:
   Case "zoomin"
      Zoom -1
   Case "zoomout"
      Zoom 1
      
   End Select
   
End Sub

Private Sub hscScroll_Change()
   Render
End Sub

Private Sub hscScroll_Scroll()
   hscScroll_Change
End Sub

Private Sub mnuFile_Click(Index As Integer)
   Select Case Index
   Case 0
      ' Open...
      Dim c As New cCommonDialog
      Dim sFile As String
      If (c.VBGetOpenFileName(sFile, _
            Filter:="All Picture Files
             (*.bmp;*.rle;*.jpg;*.jpeg;*.gif;)|*.bmp;*.rle;*.jpg;*.jpeg;*.gif;|B
            itmap Files (*.bmp;*.rle)|*.bmp|*.rle|JPEG files
             (*.jpg;*.jpeg)|*.jpg;*.jpeg)|Nasty GIF File (*.gif)|*.gif|All
             Files (*.*)|*.*", _
            Owner:=Me.hwnd)) Then
         On Error Resume Next
         picImage.Picture = LoadPicture(sFile)
         If (Err.Number <> 0) Then
            MsgBox "Failed to load image: '" & sFile & "'" & vbCrLf &
             Err.Description, vbExclamation
         Else
            m_lWidth = picImage.ScaleWidth \ Screen.TwipsPerPixelX
            m_lheight = picImage.ScaleHeight \ Screen.TwipsPerPixelY
            SetScroll
            picTest.Refresh
         End If
      End If
   Case 2
      ' Properties
      hscScroll.ButtonValue("props") = Abs(hscScroll.ButtonValue("props") - 1)
   Case 4
      ' exit
      Unload Me
   End Select
End Sub

Private Sub mnuView_Click(Index As Integer)
   If (Index = 0) Then
      hscScroll.ButtonValue("stretch") = Abs(hscScroll.ButtonValue("stretch") -
       1)
   End If
End Sub

Private Sub mnuZoom_Click(Index As Integer)
Dim l As Long
   
   For l = mnuZoom.LBound To mnuZoom.UBound
      mnuZoom(l).Checked = (Index = l)
   Next l
   m_fZoom = CSng(mnuZoom(Index).Tag)
   hscScroll.ButtonEnabled("zoomout") = Not (Index = mnuZoom.UBound)
   vscScroll.ButtonEnabled("zoomout") = Not (Index = mnuZoom.UBound)
   hscScroll.ButtonEnabled("zoomin") = Not (Index = mnuZoom.LBound)
   vscScroll.ButtonEnabled("zoomin") = Not (Index = mnuZoom.LBound)
   
   SetScroll
   picTest.Refresh
   
End Sub

Private Sub picTest_Paint()
   Render
End Sub

Private Sub picTest_Resize()
   hscScroll.Resize
   vscScroll.Resize
   SetScroll
End Sub

Private Sub vscScroll_ButtonClick(ByVal lButton As Long)
   Select Case vscScroll.ButtonKey(lButton)
   Case "pageup"
      vscScroll.Value = vscScroll.Value - vscScroll.LargeChange
   Case "pagedown"
      vscScroll.Value = vscScroll.Value + vscScroll.LargeChange
   
   ' here we're just stretching in both directions:
   Case "zoomin"
      Zoom -1
   Case "zoomout"
      Zoom 1
      
   End Select
   
End Sub

Private Sub vscScroll_Change()
   Render
End Sub

Private Sub vscScroll_Scroll()
   vscScroll_Change
End Sub