Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
     ByVal hDC As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long) As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
     ByVal hDC As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32.dll" ( _
     ByVal hDC As Long, _
     ByVal hObject As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32.dll" ( _
     ByVal hObject As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32.dll" ( _
     ByVal hDC As Long) As Long
 
Private Declare Function SetPixel Lib "gdi32.dll" ( _
     ByVal hDC As Long, _
     ByVal x As Long, _
     ByVal y As Long, _
     ByVal crColor As Long) As Long
 
Private Declare Function GetPixel Lib "gdi32.dll" ( _
     ByVal hDC As Long, _
     ByVal x As Long, _
     ByVal y As Long) As Long
 
Private Declare Function BitBlt Lib "gdi32.dll" ( _
     ByVal hDestDC As Long, _
     ByVal x As Long, _
     ByVal y As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long, _
     ByVal hSrcDC As Long, _
     ByVal xSrc As Long, _
     ByVal ySrc As Long, _
     ByVal dwRop As Long) As Long
 
Private Const SRCCOPY As Long = &HCC0020
 
 
Public Function Color2BlackWhite(ByRef oPic As PictureBox) As Long
    Dim hmemDC As Long
    Dim hBM As Long
    Dim x As Long, y As Long
    Dim Color As Long, Rot As Long, Gruen As Long, Blau As Long, Grau As Long
    Dim hDC As Long, w As Long, h As Long
 
    hDC = oPic.hDC
    w = oPic.ScaleWidth
    h = oPic.ScaleHeight
 
    'Gerätekontext im Speicher erstellen
    hmemDC = CreateCompatibleDC(hDC)
    If hmemDC = 0 Then
        Color2BlackWhite = -10
        Exit Function
    End If
    hBM = CreateCompatibleBitmap(hDC, w, h)
    If hBM = 0 Then
        DeleteDC hmemDC
        Color2BlackWhite = -20
        Exit Function
    End If
    SelectObject hmemDC, hBM
 
    'Bild pixelweise ins Memory kopieren und modifizieren
    For y = 0 To h
        For x = 0 To w
            Color = GetPixel(hDC, x, y)
            Rot = (Color And vbRed)
            Gruen = (Color And vbGreen) \ &H100
            Blau = (Color And vbBlue) \ &H10000
            Grau = (Rot * 77 + Gruen * 150 + Blau * 28) / 255
            If Grau > 128 Then
                SetPixel hmemDC, x, y, vbWhite
            End If
        Next
    Next
 
    'Ursprüngliches Bild löschen
    Set oPic.Picture = Nothing
    oPic.AutoRedraw = False
 
    'Mit einem Rutsch vom Speicher ins Bild
    BitBlt oPic.hDC, 0, 0, w, h, hmemDC, 0, 0, SRCCOPY
 
    'GDI Speicher klären
    DeleteObject hBM
    DeleteDC hmemDC
End Function