|
Ein Bild auf einem Hintergrund zu kacheln ist ein im Prinzip einfache Angelegenheit. Sie kopieren es im Paint-Ereignis eines Forms (oder einer PictureBox, eines UserControls, eines UserDocuments, einer PropertyPage) einfach so oft nebeneinander und untereinander, bis die Fläche gefüllt ist. So lange die Größe der Fläche nicht dynamisch geändert wird, ist das Verfahren auch ausreichend.
Wenn Sie aber beispielsweise die Fläche eines Forms füllen möchten, muss der beim Vergrößern des Forms entstehende Freiraum nachträglich gefüllt werden. Würden Sie hierbei auch wieder die gesamte Fläche erneut füllen, von links oben beginnend, würde es unweigerlich zu Flackereffekten kommen. Eine Optimierung für diesen Fall ist also angebracht. Dazu brauchen Sie im Resize-Ereignis lediglich festzuhalten, ob gerade eine Vergrößerung stattgefunden hat. Im nachfolgenden Paint-Ereignis entscheiden Sie dementsprechend, ob die gesamte Fläche neu gekachelt werden muss, oder ob nur die hinzugekommenen Teilbereiche ergänzt werden sollen.
Natürlich können Sie nun die Kachelei nicht einfach an den Kanten der Teilbereiche beginnen. Sie müssen vielmehr dafür sorgen, dass immer im vollständigen Kachelraster gezeichnet wird - gegebenenfalls zuvor "angebrochene" Rasterfelder müssen auch vollständig gefüllt werden. Dazu kommt, dass bei einer Vergrößerung sowohl der Breite als auch der Höhe an der rechten Seite oben und an der Unterseite links begonnen werden muss. Erfolgt die Vergrößerung nur in einer Richtung, brauchen Sie dagegen erst tatsächlich am Beginn der hinzugekommenen Fläche anzusetzen.
Denkbar ist auch eine Teilfüllung der Fläche, etwa mit einem in die Fläche hinein verschobenen Ursprung, oder mit einer verminderten Breite oder Höhe.
Die folgende Prozedur TilePicture füllt die Fläche eines VB-Objekts, das über die üblichen Eigenschaften und Methoden einer Zeichenfläche verfügt. Das Objekt wird im ersten Parameter übergeben. Die Übergabe des zu kachelnden Bildes im zweiten Parameter ist optional. Fehlt das Bild, wird versucht, das Bild der Picture-Eigenschaft des Objekts zu entnehmen. Die Start-Angaben X und Y und die maximale Breite und Höhe in den weiteren Parametern sind optional. Bei fehlenden Start-Angaben wird links bzw. oben in der Fläche begonnen. Bei fehlender Breite oder Höhe (oder Werten gleich 0) werden die kompletten Innenabmessungen (ScaleWidth bzw. ScaleHeight) angenommen. Bei negativen Werten die Start-Angaben in der entsprechenden Richtung intern aus der Fläche hinaus geschoben, so dass in dieser Richtung keine Kachelung erfolgt (dies dient zur Optimierung bei einer Größenänderung der Fläche).
Public Sub TilePicture(Obj As Object, _
Optional Picture As StdPicture, _
Optional ByVal X As Variant, _
Optional ByVal Y As Variant, _
Optional ByVal Width As Single, _
Optional ByVal Height As Single)
Dim nWidth As Single
Dim nHeight As Single
Dim nPicWidth As Single
Dim nPicHeight As Single
Dim nX As Single
Dim nY As Single
Dim nLeft As Single
Dim nPicture As StdPicture
With Obj
If Picture Is Nothing Then
On Error Resume Next
Set nPicture = .Picture
On Error GoTo 0
Else
Set nPicture = Picture
End If
If nPicture Is Nothing Then
.Cls
Exit Sub
End If
nPicWidth = .ScaleX(nPicture.Width, vbHimetric)
nPicHeight = .ScaleY(nPicture.Height, vbHimetric)
nLeft = .ScaleLeft
If IsMissing(X) Then
X = nLeft
End If
nY = .ScaleTop
If IsMissing(Y) Then
Y = nY
End If
Select Case Width
Case 0
nWidth = nLeft + .ScaleWidth
Case Is < 0
nWidth = nLeft + .ScaleWidth + nPicWidth
X = nWidth
Case Is > 0
nWidth = X + Width
End Select
Select Case Height
Case 0
nHeight = nY + .ScaleHeight
Case Is < 0
nHeight = nY + .ScaleHeight + nPicHeight
Y = nHeight
Case Is > 0
nHeight = Y + Height
End Select
Do
nX = nLeft
Do
If (nX + nPicWidth >= X) Or (nY + nPicHeight >= Y) Then
.PaintPicture nPicture, nX, nY, nPicWidth, nPicHeight
End If
nX = nX + nPicWidth
Loop Until nX > nWidth
nY = nY + nPicHeight
Loop Until nY > nHeight
End With
End Sub
Die oben beschriebene Steuerung der Kachelung bei Größenänderungen erfolgt über die Paint- und Resize-Ereignisse der Objekte - beispielsweise bei einem Form:
Private mResizePaint As Boolean
Private mLastScaleWidth As Single
Private mLastScaleHeight As Single
Private Enum TileResizeConstants
trNone
trWidth
trHeight
trBoth
End Enum
Private Sub Form_Paint()
Select Case mResizePaint
Case trNone
TilePicture Me
Case trWidth
TilePicture Me, , mLastScaleWidth, , , -1
Case trHeight
TilePicture Me, , , mLastScaleHeight, -1
Case trBoth
TilePicture Me, , mLastScaleWidth, mLastScaleHeight
End Select
With Me
mLastScaleWidth = .ScaleWidth
mLastScaleHeight = .ScaleHeight
End With
mResizePaint = trNone
End Sub
Public Sub Resize()
mResizePaint = trNone
With Me
If .WindowState <> vbMinimized Then
If .ScaleWidth > mLastScaleWidth Then
mResizePaint = trWidth
End If
If .ScaleHeight > mLastScaleHeight Then
mResizePaint = mResizePaint Or trHeight
End If
End If
End With
End Sub
Damit Sie bei mehreren Flächen-Objekten in einem Modul die Verwaltung der letzten Abmessungen (mLastScaleWidth/Height) und der Änderungsangabe (mResizePaint) mit den Ereignissen Paint und Resize nicht jeweils separat anlegen müssen, können Sie alles zusammen in eine Klasse (clsTilePicture) packen.
Das Flächen-Objekt und das Bild können Sie in einem einzigen Aufruf der Init-Methode übergeben. Sie können aber auch beides separat über die Eigenschaften Object und Picture setzen. Auch hier wird bei fehlender Angabe eines Bildes versicht, dieses der Picture-Eigenschaft des Objekts zu entnehmen. Schließlich können Sie das Bild auch alternativ beim Aufruf der Paint-Methode übergeben, die Sie aus dem Paint-Ereignis des betreffenden Objekts heraus aufrufen müssen. Die Resize-Methode ist dementsprechend aus dem Resize-Ereignis des Objekts aufzurufen. Der Code der Klasse clsTilePicture:
Private Enum TileResizeConstants
trNone
trWidth
trHeight
trBoth
End Enum
Private mResizePaint As TileResizeConstants
Private mLastScaleWidth As Single
Private mLastScaleHeight As Single
Private pObject As Object
Private pPicture As StdPicture
Public Property Get Object() As Object
Set Object = pObject
End Property
Public Property Let Object(New_Object As Object)
zSetObject New_Object
End Property
Public Property Set Object(New_Object As Object)
zSetObject New_Object
End Property
Private Sub zSetObject(New_Object As Object)
Select Case True
Case New_Object Is Nothing
Case TypeOf New_Object Is MDIForm
Err.Raise 380
Case TypeOf New_Object Is Form
Case TypeOf New_Object Is PictureBox
Case TypeOf New_Object Is UserControl
Case TypeOf New_Object Is UserDocument
Case TypeOf New_Object Is PropertyPage
Case Else
Err.Raise 380
End Select
Set pObject = New_Object
End Sub
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
End Sub
Public Sub Init(Optional Object As Object, _
Optional Picture As StdPicture)
Set Me.Object = Object
Set pPicture = Picture
End Sub
Public Sub Paint(Optional Picture As StdPicture)
Dim nPicture As StdPicture
If Not (pObject Is Nothing) Then
If Picture Is Nothing Then
Set nPicture = pPicture
End If
With pObject
If nPicture Is Nothing Then
On Error Resume Next
Set nPicture = .Picture
On Error GoTo 0
End If
If nPicture Is Nothing Then
.Cls
Else
Select Case mResizePaint
Case trNone
mTilePicture pObject, nPicture
Case trWidth
mTilePicture pObject, nPicture, mLastScaleWidth, , , -1
Case trHeight
mTilePicture pObject, nPicture, , mLastScaleHeight, -1
Case trBoth
mTilePicture pObject, nPicture, mLastScaleWidth, _
mLastScaleHeight
End Select
End If
mLastScaleWidth = .ScaleWidth
mLastScaleHeight = .ScaleHeight
End With
End If
mResizePaint = trNone
End Sub
Public Sub Resize()
mResizePaint = trNone
If Not (pObject Is Nothing) Then
With pObject
If TypeOf pObject Is Form Then
If .WindowState = vbMinimized Then
Exit Sub
End If
End If
If .ScaleWidth > mLastScaleWidth Then
mResizePaint = trWidth
End If
If .ScaleHeight > mLastScaleHeight Then
mResizePaint = mResizePaint Or trHeight
End If
End With
End If
End Sub
Private Sub mTilePicture(Obj As Object, _
Optional Picture As StdPicture, _
Optional ByVal X As Variant, _
Optional ByVal Y As Variant, _
Optional ByVal Width As Single, _
Optional ByVal Height As Single)
Dim nWidth As Single
Dim nHeight As Single
Dim nPicWidth As Single
Dim nPicHeight As Single
Dim nX As Single
Dim nY As Single
Dim nLeft As Single
Dim nPicture As StdPicture
With Obj
If Picture Is Nothing Then
On Error Resume Next
Set nPicture = .Picture
On Error GoTo 0
Else
Set nPicture = Picture
End If
If nPicture Is Nothing Then
.Cls
Exit Sub
End If
nPicWidth = .ScaleX(nPicture.Width, vbHimetric)
nPicHeight = .ScaleY(nPicture.Height, vbHimetric)
nLeft = .ScaleLeft
If IsMissing(X) Then
X = nLeft
End If
nY = .ScaleTop
If IsMissing(Y) Then
Y = nY
End If
Select Case Width
Case 0
nWidth = nLeft + .ScaleWidth
Case Is < 0
nWidth = nLeft + .ScaleWidth + nPicWidth
X = nWidth
Case Is > 0
nWidth = X + Width
End Select
Select Case Height
Case 0
nHeight = nY + .ScaleHeight
Case Is < 0
nHeight = nY + .ScaleHeight + nPicHeight
Y = nHeight
Case Is > 0
nHeight = Y + Height
End Select
Do
nX = nLeft
Do
If (nX + nPicWidth >= X) Or (nY + nPicHeight >= Y) Then
.PaintPicture nPicture, nX, nY, nPicWidth, nPicHeight
End If
nX = nX + nPicWidth
Loop Until nX > nWidth
nY = nY + nPicHeight
Loop Until nY > nHeight
End With
End Sub
|