Dim x1&, y1&, Color1&, Rot&, Gruen&, Blau&, Grau&
 
  With Picture1
    .ScaleMode = vbPixels
    .AutoRedraw = True
    For y1 = 0 To .ScaleHeight - 1
      For x1 = 0 To .ScaleWidth - 1
        Color1 = .Point(x1, y1)
        Rot = (Color1 And vbRed)
        Gruen = (Color1 And vbGreen) \ &H100
        Blau = (Color1 And vbBlue) \ &H10000
        Grau = (Rot * 77 + Gruen * 150 + Blau * 28) / 255
        Picture1.PSet (x1, y1), IIf(Grau < 128, vbBlack, vbWhite)
      Next x1
      If (y1 Mod 100) = 0 Then DoEvents
    Next y1
  End With

Gruss,

Zardoz

Zitat:

Wenn ich mich recht erinnere, kann die Point-Methode nur die Farbe an Pixelpositionen abfragen, die aktuell auf dem Formular sichtbar sind.

Gruss,

Zardoz

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