Alphablending kann man oft für Grafikeffekte brauchen. Doch mit der GetPixel- und SetPixel-Funktion dauert das eine Ewigkeit. Desshalb ist es einfacher sich das Bild direkt aus dem Speicher zu holen und dort zu bearbeiten. Nach getaner Arbeit steckt man das Bild einfach zurück. Der einzige Haken ist der, dass man nicht direkt mit den einzelnen Pixels arbeitet sondern pro Pixel 3 Variablen hat (RGB werte). Es können natürlich auch andere Effekte wie Verwischen, Farbmanipulation,Kontrast, ... nach dem selben Prinzip durchgeführt werden, indem man einfach den eigentlichen Bearbeitungsteil verändert. Für das nachfolgende Beispiel wird eine Form mit zwei PictureBox-Controls benötigt. Laden Sie in die PictureBox-Controls jeweils ein 24-Bit Bitmap und platzieren dann noch einen CommandButton auf die Form. Option Explicit ' Benötigte API-Deklarationen Private Declare Function GetObject Lib "gdi32" _ Alias "GetObjectA" ( _ ByVal hObject As Long, _ ByVal nCount As Long, _ lpObject As Any) As Long Private Declare Function VarPtrArray Lib "msvbvm50.dll" _ Alias "VarPtr" ( _ Ptr() As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" ( _ pDst As Any, _ pSrc As Any, _ ByVal ByteLen As Long) Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type 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 ' ----------ALPHABLEND------------- ' Source Quellbild ' Destination Zielbild ' X1 X-Verschiebung ' Y1 Y-Verschiebung Private Sub Alphablend(Source As PictureBox, _ Destination As PictureBox, _ Optional ByVal X1 As Long = 0, _ Optional ByVal Y1 As Long = 0, Optional Part As Byte = 50) Dim Pic() As Byte Dim PicBuff() As Byte Dim SafeArray As SAFEARRAY2D Dim SafeArrayBuffer As SAFEARRAY2D Dim Bmp As BITMAP Dim BmpBuffer As BITMAP Dim x As Long Dim y As Long Dim Temp As Long Call GetObject(Destination.Picture, Len(Bmp), Bmp) Call GetObject(Source.Picture, Len(BmpBuffer), BmpBuffer) If Bmp.bmBitsPixel <> 24 Then MsgBox "Bild ist kein 24-Bit Bitmap!" Exit Sub End If ' Deskriptor des Bytearrays dem die sichtbare ' PictureBox (Picture1) zugeordnet wird. With SafeArray .cDims = 2 .fFeatures = 0 .cbElements = 1 .cLocks = 0 .pvData = Bmp.bmBits .Bounds(0).lLbound = 0 .Bounds(0).cElements = Bmp.bmHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = Bmp.bmWidthBytes End With ' Deskriptor des Bytearrays dem die unsichtbare ' PictureBox (Picture2) zwecks Pufferung zugeordnet wird With SafeArrayBuffer .cDims = 2 .fFeatures = 0 .cbElements = 1 .cLocks = 0 .pvData = BmpBuffer.bmBits .Bounds(0).lLbound = 0 .Bounds(0).cElements = BmpBuffer.bmHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = BmpBuffer.bmWidthBytes End With ' Zuweisung der beiden neuen Deskriptoren Call CopyMemory(ByVal VarPtrArray(Pic), _ VarPtr(SafeArray), 4&) Call CopyMemory(ByVal VarPtrArray(PicBuff), _ VarPtr(SafeArrayBuffer), 4&) On Error Resume Next ' Hier kann man die Transperenz RGB Werte einstellen Dim tR As Byte Dim tG As Byte Dim tB As Byte tR = 0 tG = 255 tB = 0 ' Hier beginnt der eigentliche Effekt Y1 = -Y1 + UBound(Pic, 2) - UBound(PicBuff, 2) For x = 0 To UBound(PicBuff, 1) + 3 * (X1 - 1) Step 3 For y = 0 To UBound(PicBuff, 2) + Y1 If PicBuff(x - 3 * X1, (y - Y1)) <> tR Or _ PicBuff(x + 1 - 3 * X1, (y - Y1)) <> tG Or _ PicBuff(x + 2 - 3 * X1, (y - Y1)) <> tB Then Pic(x, y) = Int((Pic(x, y) * _ (1 - (Part / 100)) + _ PicBuff(x - 3 * X1, (y - Y1)) * (Part / 100))) Pic(x + 1, y) = Int((Pic(x + 1, y) * _ (1 - (Part / 100)) + _ PicBuff(x + 1 - 3 * X1, (y - Y1)) * (Part / 100))) Pic(x + 2, y) = Int((Pic(x + 2, y) * _ (1 - (Part / 100)) + _ PicBuff(x + 2 - 3 * X1, (y - Y1)) * (Part / 100))) End If Next y Next x ' Zurücksetzen der verbogenen Deskriptoren. Call CopyMemory(ByVal VarPtrArray(Pic), 0&, 4&) Call CopyMemory(ByVal VarPtrArray(PicBuff), 0&, 4&) ' Array aus dem Image in das Picture holen Destination.Refresh End Sub Private Sub Command1_Click() Alphablend Picture1, Picture2, 0, 0, 50 End Sub Dieser Tipp wurde bereits 22.809 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |