vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
vb@rchiv Offline-Reader - exklusiv auf der vb@rchiv CD Vol.4  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2021
 
zurück
Rubrik: Grafik und Font · Grafische Effekte   |   VB-Versionen: VB5, VB609.05.03
Alphablending mit CopyMemory

Grafikbearbeitung über die CopyMemory - Funktion

Autor:   Radlwimmer ManfredBewertung:     [ Jetzt bewerten ]Views:  21.186 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

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 21.186 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2021 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel