Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0740: Schnelle Helligkeitsänderung eines Bildes per AlphaBlend

VB 5/6-Tipp 0740: Schnelle Helligkeitsänderung eines Bildes per AlphaBlend

 von Zardoz

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdiAlphaBlend

Download: Download des Beispielprojektes [46,63 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 Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Vertikale Scrollbar "VScroll1"

' Schnelle Helligkeitsänderung eines Bildes per AlphaBlend

' Copyright © 2007 by Zardoz

Option Explicit

' GdiAlphaBlend: Windows NT/2000/XP/Vista: Included in Windows 2000 and later.
Private Declare Function GdiAlphaBlend Lib "gdi32" (ByVal hdcDest As Long, _
  ByVal XDest As Long, ByVal YDest As Long, ByVal WidthDest As Long, _
  ByVal HeightDest As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, _
  ByVal ySrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long, _
  ByVal Blendfunc As Long) As Long

' AlphaBlend: Windows NT/2000/XP/Vista: Included in Windows 2000 and later.
' AlphaBlend: Windows 95/98/Me: Included in Windows 98 and later.

' Private Declare Function AlphaBlend Lib "msimg32" (ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, _
    ByVal WidthDest As Long, ByVal HeightDest As Long, ByVal hdcSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
    ByVal WidthSrc As Long, ByVal HeightSrc As Long, ByVal Blendfunc As Long) As Long

Private SW As Long ' Bildbreite
Private SH As Long ' Bildhöhe

Private Sub Form_Load()
  Dim Dat1 As String
  Dim TmpPic As StdPicture
  
  Dat1 = App.Path & "\DemoPic1.jpeg" ' Pfad eines Bildes
  ' Pfad prüfen
  If Dir$(Dat1) = "" Then
    MsgBox "Datei nicht gefunden:" & vbCr & Dat1, vbExclamation + vbOKOnly
    Unload Me
    Exit Sub
  End If
  ' Einstellungen Form
  Me.ScaleMode = vbPixels
  Me.BackColor = RGB(100, 180, 255)

  Set TmpPic = LoadPicture(Dat1) ' Bild laden
  ' Einstellungen Picturebox2, dient als Bildspeicher
  With Picture2
    .Visible = False
    .BorderStyle = vbBSNone
    .ScaleMode = vbPixels
    SW = CLng(.ScaleX(TmpPic.Width, vbHimetric)) ' Bildbreite
    SH = CLng(.ScaleY(TmpPic.Height, vbHimetric)) ' Bildhöhe
    .Move 0, 0, SW, SH ' Größe anpassen
    .AutoRedraw = True
    .PaintPicture TmpPic, 0, 0
  End With
  Set TmpPic = LoadPicture() ' Speicher freigeben
  
  ' Einstellungen Picturebox1, dient zur Anzeige des Bildes
  With Picture1
    .ScaleMode = vbPixels
    .BorderStyle = vbBSNone
    .Move 8, 8, SW, SH
    .AutoRedraw = True
  End With
  ' Einstellungen für Scrollbar
  With VScroll1
    .Min = -255
    .Max = 255
    .SmallChange = 1
    .LargeChange = 30
    .TabStop = False
    .Value = 0
    .ZOrder vbBringToFront
  End With
  Call VScroll1_Scroll ' Startbild
End Sub

Private Sub Form_Resize()
  ' Scrollbar positionieren
  If Me.WindowState <> vbMinimized Then VScroll1.Move Me.ScaleWidth - 32, 0, 24, 550
End Sub

Private Sub VScroll1_Change()
  ' Event durchreichen
  Call VScroll1_Scroll
End Sub

Private Sub VScroll1_Scroll()
  ' Bild berechnen
  Dim Wert As Long
  
  Wert = VScroll1.Value
  With Picture1
    .BackColor = IIf(Wert < 0, vbWhite, vbBlack)
    Wert = 255 - Abs(Wert) ' Alpha-Wert errechnen
    
    ' Aufruf für GdiAlphaBlend:
    Call GdiAlphaBlend(.hDC, 0, 0, SW, SH, Picture2.hDC, 0, 0, SW, SH, &H10000 * Wert)
    
    ' Aufruf für AlphaBlend:
    ' Call AlphaBlend(.hDC, 0, 0, SW, SH, Picture2.hDC, 0, 0, SW, SH, &H10000 * Wert)
    
    .Refresh ' Auffrischen erzwingen
  End With
  ' Alpha-Wert ausgeben
  Me.Caption = Space$(5) & "Alpha = " & Wert
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------