Ich benutze: WindowXP, VB6-sp6, 1 GB RAM.
Bei Bilder über 4 Mill. Pixel Error Fehler 6.
Kleinere Bilder funktionieren tadellos!
Den Wert von hMask1, hDCMask1 ist 9 stellig (Bild ist geladen).
Es hängt sich meistens bei Test = 8 auf.
Ich vermute es liegt an BitBlt().
Hie nochmal die ganze Routine:
Private Function MonoMask(Source As PictureBox, ByVal MaskColor&, Mask1 As PictureBox, ByVal Mask2 As PictureBox, ByVal Mask3 As PictureBox) As Boolean
Dim hDCMask1&, hMask1&, hDCMask2&, hMask2&
Dim hPrevMask1&, hPrevMask2&, W&, H&
Dim I%, J%, Col&, Test%
Dim ret As Long
On Error GoTo Err
W = Source.Width
H = Source.Height
Mask1.Width = W
Mask1.Height = H
Mask2.Width = W
Mask2.Height = H
Mask3.Width = W
Mask3.Height = H
'Generieren zweier Bitmaps
hDCMask1 = CreateCompatibleDC(Mask1.hDC)
hDCMask2 = CreateCompatibleDC(Mask1.hDC)
Test = 1
hMask1 = CreateBitmap(W, H, 1, 1, ByVal 0&)
hMask2 = CreateBitmap(W, H, 1, 1, ByVal 0&)
Test = 2
hPrevMask1 = SelectObject(hDCMask1, hMask1)
hPrevMask2 = SelectObject(hDCMask2, hMask2)
Test = 3
'Maskenfarbe des Originalbildes festlegen
Call SetBkColor(Source.hDC, MaskColor)
Test = 4
'Monochrome Maske des Originalbildes erstellen
Call BitBlt(hDCMask1, 0, 0, W, H, Source.hDC, _
0, 0, SRCCOPY)
Test = 5
'Erstellte monochrome Maske nach PicMask kopieren
Call BitBlt(Mask1.hDC, 0, 0, W, H, _
hDCMask1, 0, 0, SRCCOPY)
Test = 6
'S/W Fehlerbehandlung PicMask (Sollte Maske grau sein)
If sysMask_Err Then
Mask1.Picture = Mask1.image
ret = ToGreyByPalette(Mask1.hDC, Mask1.Picture, Mask1.image, 2) 'ModSW
End If
Test = 7
'Inverse Maske der erstellen Maske generieren
Call BitBlt(hDCMask2, 0, 0, W, H, _
hDCMask1, 0, 0, vbNotSrcCopy)
Test = 8
'Erstellte inverse Maske nach MaskInvers kopieren PicDummy
Call BitBlt(Mask2.hDC, 0, 0, W, H, _
hDCMask2, 0, 0, SRCCOPY)
Test = 9
'S/W Fehlerbehandlung PicImage
If sysMask_Err Then
Mask2.Picture = Mask2.image
ret = ToGreyByPalette(Mask2.hDC, Mask2.Picture, Mask2.image, 2) 'ModSW
End If
Test = 10
'Beim laden auf S/W-Fehler prüfen. (WindowBlinds)
If Not (sysMask_ErrCheck) Then 'PicDummy
sysMask_ErrCheck = True
For I = 1 To W - 1
For J = 1 To H - 1
Col = GetPixel(Mask1.hDC, I, J)
If Col <> vbWhite And Col <> vbBlack Then
sysMask_Err = True
Exit For
End If
Col = GetPixel(Mask2.hDC, I, J)
If Col <> vbWhite And Col <> vbBlack Then
sysMask_Err = True
Exit For
End If
Next J
Next I
End If
Test = 11
'Originalbildes in die Schlußmaske kopieren PicImage
Call BitBlt(Mask3.hDC, 0, 0, W, H, Source.hDC, _
0, 0, SRCCOPY)
Test = 12
'AND der Schlußmaske mit der invertierten Maske
Call BitBlt(Mask3.hDC, 0, 0, W, H, _
Mask2.hDC, 0, 0, SRCAND)
Test = 13
'Erstellte Objekte & DCs wieder freigeben
Call DeleteObject(SelectObject(hDCMask1, hPrevMask1))
Call DeleteObject(SelectObject(hDCMask2, hPrevMask2))
Test = 14
Call DeleteDC(hDCMask1)
Call DeleteDC(hDCMask2)
MonoMask = True
Exit Function
Err:
sysMask_OnErr = True
Call PicErr(Err.Number, "Test: " & Test & " hMask1: " & hMask1 & " hMask2: " & hMask2 & " hPrevMask1: " & hPrevMask1 & " Mask2.hDC: " & Mask2.hDC)
Err = 0
'Erstellte Objekte & DCs wieder freigeben
Call DeleteObject(SelectObject(hDCMask1, hPrevMask1))
Call DeleteObject(SelectObject(hDCMask2, hPrevMask2))
Call DeleteDC(hDCMask1)
Call DeleteDC(hDCMask2)
MonoMask = False
Exit Function
End Function
Gruß
Fieber
http://computer.net-berlin.de - Visual Basic - Tips & Tricks sowie viel Grafik |
Forenübersicht Suchen Forumsregeln
Sie sind aktuell nicht angemeldet.
