Bild aufhellen und abdunkeln Bild mit VB6-Mitteln einfach und schnell aufhellen bzw. abdunkeln
Autor:   BT-Soft	Bewertung:	Views:  202
https://bt-soft.de	System:  Win7, Win8, Win10, Win11	Beispielprojekt

Mit diesem von ChatGPT und mir erstelltem, reinen VB6-Code, wird ein Bild einfach und vor allem schnell aufgehellt und abgedunkelt.

Benötigt wird:

• Form1
• Picture1 mit AutoRedraw = True und AutoSize = True
• Menüpunkte Heller, Dunkler, Original
• modBrightness.bas

' ========================
' Code für die Menüpunkte:
' ========================
 
Private Sub mnuDunkler_Click()
  BrightenFast Picture1, -20 ' dunkler
End Sub
 
Private Sub mnuHeller_Click()
  BrightenFast Picture1, 20   ' heller
End Sub
 
Private Sub mnuOriginal_Click()
  Picture1.Picture = LoadPicture(App.Path & "Bhf Giengen.jpg")
End Sub

' ===========================
' Code für modBrightness.bas:
' ===========================
 
Private Type BITMAPINFOHEADER
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
 
Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type
 
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type
 
Private Declare Function CreateDIBSection Lib "gdi32" ( _
  ByVal hDC As Long, _
  pBitmapInfo As Any, _
  ByVal un As Long, _
  lplpVoid As Long, _
  ByVal handle As Long, _
  ByVal dw As Long) As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
  ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
  ByVal w As Long, ByVal h As Long, _
  ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
  ByVal RasterOp As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  Destination As Any, Source As Any, ByVal Length As Long)
 
Private Const SRCCOPY As Long = &HCC0020

' ============
' Code für Sub
' ============
 
Public Sub BrightenFast(ByRef pic As PictureBox, ByVal Percent As Long)
  Dim bmi As BITMAPINFO
  Dim hDIB As Long
  Dim pBits As Long
  Dim hMemDC As Long
  Dim oldObj As Long
  Dim w As Long, h As Long
  Dim arr() As Byte
  Dim i As Long
  Dim gamma As Double
 
  pic.ScaleMode = vbPixels
  w = pic.ScaleWidth
  h = pic.ScaleHeight
 
  ' --- Bitmap Setup ---
  With bmi.bmiHeader
    .biSize = Len(bmi.bmiHeader)
    .biWidth = w
    .biHeight = -h
    .biPlanes = 1
    .biBitCount = 32
    .biCompression = 0
  End With
 
  ' --- DIBSection (echter Pixelbuffer) ---
  hDIB = CreateDIBSection(pic.hDC, bmi, 0, pBits, 0, 0)
 
  ' --- DC + Bild rein ---
  hMemDC = CreateCompatibleDC(pic.hDC)
  oldObj = SelectObject(hMemDC, hDIB)
  BitBlt hMemDC, 0, 0, w, h, pic.hDC, 0, 0, SRCCOPY
 
  ' --- Pixel holen ---
  ReDim arr(0 To (w * h * 4) - 1)
  CopyMemory arr(0), ByVal pBits, UBound(arr) + 1
 
  ' --- Gamma berechnen ---
  ' Percent: -100..+100
  ' sinnvoller Bereich: 0.3 bis 3.0
  If Percent >= 0 Then
    gamma = 1# - (Percent / 150#)
    If gamma < 0.3 Then gamma = 0.3
  Else
    gamma = 1# + (Abs(Percent) / 100#)
    If gamma > 3# Then gamma = 3#
  End If
 
  ' --- LUT (viel schneller als IF pro Pixel) ---
  Dim lut(0 To 255) As Byte
  Dim v As Long
  For i = 0 To 255
    v = 255 * ((i / 255) ^ gamma)
    If v < 0 Then v = 0
    If v > 255 Then v = 255
    lut(i) = v
  Next i
 
  ' --- Pixel bearbeiten (BGRA) ---
  For i = 0 To UBound(arr) Step 4
    arr(i) = lut(arr(i))         ' B
    arr(i + 1) = lut(arr(i + 1)) ' G
    arr(i + 2) = lut(arr(i + 2)) ' R
  Next i
 
  ' --- zurückschreiben ---
  CopyMemory ByVal pBits, arr(0), UBound(arr) + 1
 
  ' --- anzeigen ---
  BitBlt pic.hDC, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY
 
  ' --- cleanup ---
  SelectObject hMemDC, oldObj
  DeleteDC hMemDC
  pic.Refresh
End Sub

Copyright ©2000-2026 vb@rchiv Dieter OtterAlle 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.