Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0432: Schnelle grafische Operationen Get- und SetBitmap

VB 5/6-Tipp 0432: Schnelle grafische Operationen Get- und SetBitmap

 von ActiveVB

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetBitmapBits, GetObjectA (GetObject), SetBitmapBits

Download: Download des Beispielprojektes [28,43 KB]

'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 Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Horizontale Scrollbar "HScroll1" (Index von 0 bis 2)
' Steuerelement: Bildfeld-Steuerelement "Picture1"


'Anmerkung: Wie immer bei grafischen Manipulationen sollte der
'           Source zum besseren Genuß erst als Exe kompiliert
'           werden!

Option Explicit

Private Declare Function GetBitmapBits Lib "gdi32" (ByVal _
        hBitmap As Long, ByVal dwCount As Long, lpBits As Any) _
        As Long
        
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal _
        hBitmap As Long, ByVal dwCount As Long, lpBits As Any) _
        As Long

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

'Byte Arrays für die Bitmap
Dim PicO() As Byte
Dim PicW() As Byte
Private Blend(0 To 255, 0 To 2) As Byte

Dim ColRes As Long
Dim Init As Boolean

Private Sub Form_Load()
  Dim x As Integer
  
    Picture1.Picture = LoadPicture(App.Path & "\vbufo.jpg")
    For x = 0 To 255
      Blend(x, 0) = x
      Blend(x, 1) = x
      Blend(x, 2) = x
    Next x
End Sub

Private Sub HScroll1_Change(Index As Integer)
  Call MakeBlend(Index)
End Sub

Private Sub HScroll1_Scroll(Index As Integer)
  Call MakeBlend(Index)
End Sub

Private Sub MakeBlend(Index As Integer)
  Dim x As Long, x1 As Integer
    
    If Not Init Then
      Call InitArray(PicO, PicW)
      Init = True
    End If
    
    For x = 0 To 255
      x1 = x + HScroll1(Index).Value - 256
      
      If x1 > 255 Then
        x1 = 255
      ElseIf x1 < 0 Then
        x1 = 0
      End If
      
      Blend(x, Index) = x1
    Next x
    
    Call FilterArray(PicO, PicW)
End Sub

Private Sub FilterArray(F1() As Byte, F2() As Byte)
  Dim x As Long
  
    'Filter berrechnen
    For x = 0 To UBound(F1) - 2 Step ColRes
      F2(x) = Blend(F1(x), 2)
      F2(x + 1) = Blend(F1(x + 1), 1)
      F2(x + 2) = Blend(F1(x + 2), 0)
    Next x

    'Bild zurückschreiben
    Call SetBitmapBits(Picture1.Image, UBound(F2), F2(0))
                       
    'Image übernehmen
    Picture1.Refresh
End Sub

Private Sub InitArray(F1() As Byte, F2() As Byte)
  Dim PInf As BITMAP
 
    'Abmaße ermitteln
    Call GetObject(Picture1.Image, Len(PInf), PInf)
    
    With PInf
      'Eingestellte Farbtiefe ermitteln
      ColRes = .bmBitsPixel / 8

      If ColRes <> 3 And ColRes <> 4 Then
         MsgBox ("Stellen Sie Ihre Bildschirmauflösung bitte" & _
                 " vorab auf 24 oder 32 Bit Farbtiefe um!")
         End
      End If
      
      'Arrays dimensionieren
      ReDim F1(0 To .bmWidth * .bmHeight * ColRes - 1) As Byte
      ReDim F2(0 To .bmWidth * .bmHeight * ColRes - 1) As Byte
      
    End With
    
    'Bitmap in das Array kopieren
    Call GetBitmapBits(Picture1.Image, UBound(F1), F1(0))
    Call GetBitmapBits(Picture1.Image, UBound(F2), F2(0))
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.