VB 5/6-Tipp 0075: Scrollen einer PictureBox

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Es muss ein Verweis auf 'Microsoft DAO 2.5/3.0 Compatibility Library' gesetzt werden.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Vertikale Scrollbar "VScroll1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Bildfeld-Steuerelement "Picture2" auf Picture1

Option Explicit

Private Sub Form_Load()
  Picture2.Left = 0
  Picture2.Top = 0
  VScroll1.LargeChange = Picture1.Height / 4
  VScroll1.SmallChange = 120
  HScroll1.LargeChange = Picture1.Width / 4
  HScroll1.SmallChange = 120
End Sub

Private Sub Command1_Click()
  Unload Me
End Sub

Private Sub HScroll1_Change()
  Picture2.Left = -HScroll1.Value
End Sub

Private Sub VScroll1_Change()
  Picture2.Top = -VScroll1.Value
End Sub

Private Sub HScroll1_Scroll()
  Picture2.Left = -HScroll1.Value
End Sub

Private Sub VScroll1_Scroll()
  Picture2.Top = -VScroll1.Value
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Option Explicit

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Type BITMAP
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private mBmp As BITMAP

Private Sub Form_Load()
  Dim temp As Long

  With Picture1
    .ScaleMode = 3
    .Picture = LoadPicture("Test.bmp") 'Test.bmp durch einen
                                       'echten Dateinamen                                                                                                        'ersetzen
    temp = GetObject(.Picture, Len(mBmp), mBmp)
    .PaintPicture .Picture, 0, 0, _
                  .ScaleWidth, .ScaleHeight, _
                  0, 0, _
                  .ScaleWidth, .ScaleHeight, _
                  vbSrcCopy
    HScroll1.Min = 0
    HScroll1.Max = mBmp.bmWidth - .ScaleWidth
    HScroll2.Min = 1  ' sonst Division durch Null
    HScroll2.Max = 8  ' maximal 8-fach Zoom
    VScroll1.Min = 0
    VScroll1.Max = mBmp.bmHeight - .ScaleHeight
  End With
End Sub

Private Sub HScroll1_Change()
  With Picture1
    .PaintPicture .Picture, _
          0, 0, _
          .ScaleWidth, .ScaleHeight, _
          HScroll1.Value, VScroll1.Value, _
          .ScaleWidth / HScroll2.Value, .ScaleHeight / HScroll2.Value, _
          vbSrcCopy
  End With
End Sub

Private Sub HScroll1_Scroll()
  HScroll1_Change
End Sub

Private Sub HScroll2_Change()
  HScroll1_Change
End Sub

Private Sub VScroll1_Change()
  HScroll1_Change
End Sub

Private Sub VScroll1_Scroll()
  HScroll1_Change
End Sub