ABOUT Visual Basic - das Webmagazin: Daumennagelei (UserControl)

ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE

(-hg)

Trotz der gefährlich klingenden Überschrift dieses Artikels brauchen Sie keine Angst um Ihre Daumen und Daumennägel zu haben. Es geht hier nur um so genannte "Thumbnails", um kleine Vorschaubilder, üblicherweise etwa in Daumennagel-Größe. Und das in diesem Artikel vorgestellte UserControl ThumbNail passt dazu ein Bild proportional korrekt in die aktuelle Größe bzw. Kleinheit des Steuerelements ein. Zudem können Sie das eingepasste Abbild als neues Picture-Objekt erhalten und als Mini-Abbild in einer Datei speichern.



	Das Thumbnail-Steuerelement sorgt für skalierte Vorschaubildchen unter Beibehaltung der Seitenverhältnisse

Natürlich brauchen Sie sich nicht auf Minibilder zu beschränken. Da das Steuerelement seinen Dienst in jeder Größe versieht, können Sie es auch dazu verwenden, etwa Form-füllende Vorschauen einzurichten, in die das jeweilige Bild größtmöglichst unter Beibehaltung des Seitenverhältnisses vor einer beliebigen Hintergrundfarbe (Eigenschaft BackColor) dargestellt wird. Alternativ können Sie ein Bild aber auch die gesamte Fläche des Steuerelements füllend und damit meistens verzerrt anzeigen (Eigenschaft Stretch).

Die eigentliche Arbeit wird von der privaten Prozedur zPaintPicture erledigt:

Private Sub zPaintPicture()
  Dim nLeft As Single
  Dim nTop As Single
  Dim nWidth As Single
  Dim nHeight As Single
  Dim nDestAspect As Single
  Dim nImageAspect As Single
  Dim nScaleWidth As Single
  Dim nScaleHeight As Single
  Dim nBackColor As Long
  
  With UserControl

Wenn sich in der privaten Eigenschafts-Variablen (zu den dazu gehörenden Eigenschafts-Prozeduren kommen wir später noch) kein Bild befindet, wird der gegebenenfalls angezeigte Bildinhalt sinnvollerweise gelöscht.

  If pPicture Is Nothing Then
  Set .Picture = Nothing
  Exit Sub

Soll das Bild flächenfüllend angezeigt werden (pStretch = True), wird das Bild einfach mit der PaintPicture-Methode in das UserControl hineingemalt. Dabei ist die Eigenschaft AutoRedraw vorauübergehend auf True gesetzt, so dass das frisch gemalte Abbild aus der Image-Eigenschaft ausgelesen und der dauerhaften Picture-Eigenschaft zugewiesen werden kann.

  ElseIf pStretch Then
  .AutoRedraw = True
  .PaintPicture pPicture, 0, 0, .ScaleWidth, .ScaleHeight
  Set .Picture = .Image
  .AutoRedraw = False

Soll das Bild eingepasst werden (unserer eigentlichen Absicht entsprechend), werden zunächst die Abmessungen des Bildes als auch die Innenabmessungen der Zeichenfläche des UserControls ausgelesen und zur schnelleren Verarbeitung in prozedurlokalen Variablen abgelegt. Dazu werden die Seitenverhältnisse des Bildes und der Zeichenfläche ermittelt.

  Else
  nScaleWidth = .ScaleWidth
  nScaleHeight = .ScaleHeight
  With pPicture
  nWidth = .Width
  nHeight = .Height
  End With
  nDestAspect = nScaleWidth / nScaleHeight
  nImageAspect = nWidth / nHeight

Ist das Seitenverhältnis des Bildes kleiner oder gleich dem der Zeichenfläche, muss das Bild in die volle Innenhöhe der Zeichenfläche eingepasst werden. Die Breite des Bildes ist dagegen kleiner als die Innenbreite der Zeichenfläche, so dass das Bild horizontal zu zentrieren ist.

      If nImageAspect <= nDestAspect Then
        nWidth = nWidth / (nHeight / nScaleHeight)
        nHeight = nScaleHeight
        nLeft = (nScaleWidth - nWidth) \ 2
      Else

Anderenfalls muss das Bild in die volle Innenbreite der Zeichenfläche eingepasst und vertikal zentriert werden.

        nHeight = nHeight / (nWidth / nScaleWidth)
        nWidth = nScaleWidth
        nTop = (nScaleHeight - nHeight) \ 2
      End If
      .AutoRedraw = True
      nBackColor = .BackColor

Nun überdecken wir die rechts und links bzw. oberhalb und unterhalb des Bildes verbleibenden Freiräume mit der Hintergrundfarbe.

      If nLeft Then
        UserControl.Line _
         (0, 0)-(nLeft, nScaleHeight), nBackColor, BF
        UserControl.Line _
         (nLeft + nWidth, 0)-(nScaleWidth, nScaleHeight), _
         nBackColor, BF
      ElseIf nTop Then
        UserControl.Line _
         (0, 0)-(nScaleWidth, nTop), nBackColor, BF
        UserControl.Line _
         (0, nTop + nHeight)-(nScaleWidth, nScaleHeight), _
         nBackColor, BF
      End If

Schließlich geben wir das Bild an der berechneten Stelle in der berechneten Größe aus und weisen das Malergebnis der Picture-Eigenschaft zu.

      .PaintPicture pPicture, nLeft, nTop, nWidth, nHeight
      Set .Picture = .Image
      .AutoRedraw = False
    End If
  End With
End Sub

Im Grunde haben wir die gestellte Aufgabe damit auch schon erledigt. Des weiteren bräuchten wir nun nur noch die Routinearbeiten erledigen, damit aus dem UserControl ein komfortabel verwendbares Steuerelement wird.

Zuvor allerdings schieben wir noch eine kleine Optimierung ein, damit das ThumbNail-Steuerelement nicht den Anwender beim schnellen Blättern durch eine Bild-Dateiliste ausbremst. Denn jeder Malvorgang dauert eine gewisse Zeit, wenn ein neues Bild zur Ausgabe übergeben worden ist. Etwa beim Blättern durch ein FileList-Steuerelement der Reihe nach geladene und übergebene Bild-Objekte würden auch der Reihe nach angezeigt - die Bedienung wird dann ziemlich träge und irgendwie "gummiartig". Über die Eigenschaft PaintAsync können Sie festlegen, ob die Zuweisung eines neuen Bild-Objekts (und auch jede andere sich auf die Darstellung auswirkende Eigenschaften-Änderung wie BackColor und Stretch) von der Ausgabe entkoppelt werden soll.

Zu Entkopplung bedienen wir uns eines Timers, der bei einer Änderung eingeschaltet wird. Sollte er schon eingeschaltet sein, weil die jüngste Änderung noch vor Ablauf des Timer-Intervalls erfolgt, wird er neu angeworfen - seine Enabled-Eigenschaft wird auf False und gleich wieder auf True gesetzt. Beim Eintreffen des nächsten Timer-Ereignisses schaltet sich der Timer wieder selbst ab und startet eine Ausgabe des zuletzt geladenen Bildes.

Public Property Get PaintAsync() As Boolean
  PaintAsync = pPaintAsync
End Property

Public Property Let PaintAsync(New_PaintAsync As Boolean)
  pPaintAsync = New_PaintAsync
  If Not pPaintAsync Then
    tmr.Enabled = False
  End If
  PropertyChanged "PaintAsync"
End Property

Public Property Get Picture() As StdPicture
  Set Picture = pPicture
End Property

Public Property Let Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Public Property Set Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Private Sub zSetPicture(New_Picture As StdPicture)
  Set pPicture = New_Picture
  zPaint
  PropertyChanged "Picture"
End Sub

Private Sub tmr_Timer()
  tmr.Enabled = False
  zPaintPicture
End Sub

Private Sub zPaint()
  If pPaintAsync Then
    With tmr
      .Enabled = False
      .Enabled = True
    End With
  Else
    zPaintPicture
  End If
End Sub

Voreingestellt ist ein Timer-Intervall von 1 Millisekunde. Über die Eigenschaft AsyncInterval können Sie die Verzögerung jederzeit beliebig anpassen:

Public Property Get AsyncInterval() As Long
  AsyncInterval = tmr.Interval
End Property

Public Property Let AsyncInterval(New_AsyncInterval As Long)
  tmr.Interval = New_AsyncInterval
  PropertyChanged "AsyncInterval"
End Property

Ein weiteres nettes Feature bietet die Eigenschaft Square. Wird sie auf True gesetzt, bleibt das UserControl immer quadratisch.

Public Property Get Square() As Boolean
  Square = pSquare
End Property

Public Property Let Square(New_Square As Boolean)
  If pSquare <> New_Square Then
    pSquare = New_Square
    UserControl_Resize
    PropertyChanged "Square"
  End If
End Property

Private Sub UserControl_Resize()
  Static sInProc As Boolean
    
  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  On Error Resume Next
  With UserControl
    If pSquare Then
      .Height = .Width
    End If
  End With
  zPaint
  sInProc = False
End Sub

Der Rest ist nun wirklich nur noch Kosmetik und Routine - etwa die Eigenschaften Appearance, BorderStyle, BackColor und Stretch, sowie die Nur-Lese-Eigenschaft zur Ausgabe des eingepassten Abbildes als eigenes Bild-Objekt. Ebenfalls zur Routine gehört das Speichern und Auslesen der Eigenschaften ins bzw. aus dem PropertyBag als auch die Verarbeitung der Ereignisse Click, DblClick, KeyDown, KeyAscii, KeyUp, MouseDown, MouseMove und MouseUp, die einfach nach außen weitergereicht werden.

Hier noch einmal der vollständige Code des UserControls ThumbNail:

Public Enum tnAppearanceConstants
  tnFlat = 0
  tn3D = 1
End Enum

Public Enum tnBorderStyleConstants
  tnBSNone = 0
  tnBSSingle = 1
End Enum

Public Event Click()
Public Event DblClick()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseDown(ByVal Button As Integer, _
 ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Public Event MouseMove(ByVal Button As Integer, _
 ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Public Event MouseUp(ByVal Button As Integer, _
 ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Private pPaintAsync As Boolean
Private pPicture As StdPicture
Private pSquare As Boolean
Private pStretch As Boolean

Public Property Get Appearance() As tnAppearanceConstants
  Appearance = UserControl.Appearance
End Property

Public Property Let Appearance(New_Appearance _
 As tnAppearanceConstants)

  UserControl.Appearance = New_Appearance
  PropertyChanged "Appearance"
End Property

Public Property Get AsyncInterval() As Long
  AsyncInterval = tmr.Interval
End Property

Public Property Let AsyncInterval(New_AsyncInterval As Long)
  tmr.Interval = New_AsyncInterval
  PropertyChanged "AsyncInterval"
End Property

Public Property Get BackColor() As OLE_COLOR
  BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(New_BackColor As OLE_COLOR)
  UserControl.BackColor = New_BackColor
  zPaint
  PropertyChanged "BackColor"
End Property

Public Property Get BorderStyle() As tnBorderStyleConstants
  BorderStyle = UserControl.BorderStyle
End Property

Public Property Let BorderStyle(New_BorderStyle _
 As tnBorderStyleConstants)

  UserControl.BorderStyle = New_BorderStyle
  PropertyChanged "BorderStyle"
End Property

Public Property Get Image() As StdPicture
  Set Image = UserControl.Picture
End Property

Public Property Get PaintAsync() As Boolean
  PaintAsync = pPaintAsync
End Property

Public Property Let PaintAsync(New_PaintAsync As Boolean)
  pPaintAsync = New_PaintAsync
  If Not pPaintAsync Then
    tmr.Enabled = False
  End If
  PropertyChanged "PaintAsync"
End Property

Public Property Get Picture() As StdPicture
  Set Picture = pPicture
End Property

Public Property Let Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Public Property Set Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Private Sub zSetPicture(New_Picture As StdPicture)
  Set pPicture = New_Picture
  zPaint
  PropertyChanged "Picture"
End Sub

Public Property Get Square() As Boolean
  Square = pSquare
End Property

Public Property Let Square(New_Square As Boolean)
  If pSquare <> New_Square Then
    pSquare = New_Square
    UserControl_Resize
    PropertyChanged "Square"
  End If
End Property

Public Property Get Stretch() As Boolean
  Stretch = pStretch
End Property

Public Property Let Stretch(New_Stretch As Boolean)
  If pStretch <> New_Stretch Then
    pStretch = New_Stretch
    zPaint
    PropertyChanged "Stretch"
  End If
End Property

Public Sub Refresh()
  zPaintPicture
End Sub

Private Sub tmr_Timer()
  tmr.Enabled = False
  zPaintPicture
End Sub

Private Sub UserControl_Click()
  RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
  RaiseEvent DblClick
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
  RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, _
 Shift As Integer, X As Single, Y As Single)

  RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, _
 Shift As Integer, X As Single, Y As Single)

  RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, _
 Shift As Integer, X As Single, Y As Single)

  RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Resize()
  Static sInProc As Boolean
    
  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  On Error Resume Next
  With UserControl
    If pSquare Then
      .Height = .Width
    End If
  End With
  zPaint
  sInProc = False
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  With UserControl
    .Appearance = PropBag.ReadProperty("Appearance", tn3D)
    .BackColor = PropBag.ReadProperty("BackColor", _
     vbWindowBackground)
    .BorderStyle = PropBag.ReadProperty("BorderStyle", tnBSSingle)
  End With
  tmr.Interval = PropBag.ReadProperty("AsyncInterval", 1)
  pPaintAsync = PropBag.ReadProperty("PaintAsync", False)
  Set pPicture = PropBag.ReadProperty("Picture", Nothing)
  pSquare = PropBag.ReadProperty("Square", False)
  pStretch = PropBag.ReadProperty("Stretch", False)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "Appearance", UserControl.Appearance, tn3D
  PropBag.WriteProperty "AsyncInterval", tmr.Interval, 1
  PropBag.WriteProperty "BackColor", UserControl.BackColor, _
   vbWindowBackground
  PropBag.WriteProperty "BorderStyle", UserControl.BorderStyle, _
   tnBSSingle
  PropBag.WriteProperty "PaintAsync", pPaintAsync, False
  PropBag.WriteProperty "Picture", pPicture, Nothing
  PropBag.WriteProperty "Square", pSquare, False
  PropBag.WriteProperty "Stretch", pStretch, False
End Sub

Private Sub zPaint()
  If pPaintAsync Then
    With tmr
      .Enabled = False
      .Enabled = True
    End With
  Else
    zPaintPicture
  End If
End Sub

Private Sub zPaintPicture()
  Dim nLeft As Single
  Dim nTop As Single
  Dim nWidth As Single
  Dim nHeight As Single
  Dim nDestAspect As Single
  Dim nImageAspect As Single
  Dim nScaleWidth As Single
  Dim nScaleHeight As Single
  Dim nBackColor As Long
  
  With UserControl
    If pPicture Is Nothing Then
      Set .Picture = Nothing
      Exit Sub
    ElseIf pStretch Then
      .AutoRedraw = True
      .PaintPicture pPicture, 0, 0, .ScaleWidth, .ScaleHeight
      Set .Picture = .Image
      .AutoRedraw = False
    Else
      nScaleWidth = .ScaleWidth
      nScaleHeight = .ScaleHeight
      With pPicture
        nWidth = .Width
        nHeight = .Height
      End With
      nDestAspect = nScaleWidth / nScaleHeight
      nImageAspect = nWidth / nHeight
      If nImageAspect <= nDestAspect Then
        nWidth = nWidth / (nHeight / nScaleHeight)
        nHeight = nScaleHeight
        nLeft = (nScaleWidth - nWidth) \ 2
      Else
        nHeight = nHeight / (nWidth / nScaleWidth)
        nWidth = nScaleWidth
        nTop = (nScaleHeight - nHeight) \ 2
      End If
      .AutoRedraw = True
      nBackColor = .BackColor
      If nLeft Then
        UserControl.Line _
         (0, 0)-(nLeft, nScaleHeight), nBackColor, BF
        UserControl.Line _
         (nLeft + nWidth, 0)-(nScaleWidth, nScaleHeight), _
         nBackColor, BF
      ElseIf nTop Then
        UserControl.Line (0, 0)-(nScaleWidth, nTop), _
         nBackColor, BF
        UserControl.Line _
         (0, nTop + nHeight)-(nScaleWidth, nScaleHeight), _
         nBackColor, BF
      End If
      .PaintPicture pPicture, nLeft, nTop, nWidth, nHeight
      Set .Picture = .Image
      .AutoRedraw = False
    End If
  End With
End Sub

Beispiel-Projekt und UserControl ThumbNail (thumbnail.zip - ca. 53 KB)

					Copyright © 1999 - 2023 Harald M. Genauck, ip-pro gmbh / Impressum