VB 5/6-Tipp 0257: Optisches Schärfen einer 24-Bit-Bitmap
von ActiveVB
Beschreibung
Auch ein Schärfen Effekt ist durchaus möglich, hier wird in einer Schleife das aktuelle Pixel mit seinem Vorgänger verrechntet.Siehe auch Tipp 431 und Tipp 432
Schwierigkeitsgrad: | Verwendete API-Aufrufe: BitBlt, RtlMoveMemory (CopyMemory), GetObjectA (GetObject), VarPtr (VarPtrArray) | Download: |
'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 Project1.vbp ------------- '--------- Anfang Formular "Form1" alias Form1.frm --------- ' Steuerelement: Schaltfläche "Command2" ' Steuerelement: Schaltfläche "Command1" ' Steuerelement: Bildfeld-Steuerelement "Picture1" ' Steuerelement: Bildfeld-Steuerelement "Picture2" 'Der Tip wird erst zur .exe kompiliert zum wahren Genuß! Option Explicit Private Declare Function BitBlt Lib "gdi32" (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 Declare Function GetObject Lib "gdi32" Alias _ "GetObjectA" (ByVal hObject As Long, ByVal nCount As _ Long, lpObject As Any) As Long Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias _ "VarPtr" (Ptr() As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias _ "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal _ ByteLen As Long) Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY1D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 0) As SAFEARRAYBOUND End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Const SRCCOPY = &HCC0020 Private Sub Form_Load() Call ResetBitmap End Sub Private Sub Command1_Click() Call MakeBitmap Picture1.Refresh End Sub Private Sub Command2_Click() Call ResetBitmap End Sub Private Sub MakeBitmap() Dim Pic() As Byte, PicBuff() As Byte Dim SA As SAFEARRAY2D, Bmp As BITMAP Dim SABuff As SAFEARRAY2D, BmpBuff As BITMAP Dim x%, y%, Temp% Call GetObject(Picture1.Picture, Len(Bmp), Bmp) Call GetObject(Picture2.Picture, Len(BmpBuff), BmpBuff) If Bmp.bmBitsPixel <> 24 Then MsgBox "Es werden nur 24-Bit Bitmaps unterstützt!" Exit Sub End If With SA .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = Bmp.bmHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = Bmp.bmWidthBytes .pvData = Bmp.bmBits End With Call CopyMemory(ByVal VarPtrArray(Pic), VarPtr(SA), 4) With SABuff .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = BmpBuff.bmHeight .Bounds(1).lLbound = 0 .Bounds(1).cElements = BmpBuff.bmWidthBytes .pvData = BmpBuff.bmBits End With Call CopyMemory(ByVal VarPtrArray(PicBuff), VarPtr(SABuff), 4) For x = 3 To UBound(Pic, 1) - 3 For y = 0 To UBound(Pic, 2) Temp = (CInt(PicBuff(x, y)) + 0.5 * (CInt(PicBuff(x, y)) _ - CInt(PicBuff(x - 3, y)))) If Temp > 255 Then Temp = 255 If Temp < 0 Then Temp = 0 Pic(x, y) = Temp Next y Next x Call CopyMemory(ByVal VarPtrArray(Pic), 0&, 4) Call CopyMemory(ByVal VarPtrArray(PicBuff), 0&, 4) End Sub Private Sub ResetBitmap() Picture1.Picture = LoadPicture(App.Path & "\Bild.jpg") Picture2.Picture = LoadPicture(App.Path & "\Bild.jpg") End Sub '---------- Ende Formular "Form1" alias Form1.frm ---------- '-------------- Ende Projektdatei Project1.vbp --------------
Tipp-Kompatibilität:
Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | |||||||
VB5 | |||||||
VB6 |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.
Archivierte Nutzerkommentare
Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.
Kommentar von Karl Heinz am 13.07.2006 um 14:16
Der Tipp funktioniert nicht mit Bilder aus der Zwischenablage:
Private Sub ResetBitmap()
' Picture1.Picture = LoadPicture(App.Path & "\Bild.bmp")
' Picture2.Picture = LoadPicture(App.Path & "\Bild.bmp")
Picture2.Picture = Clipboard.GetData(vbCFBitmap)
Picture1.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Fehlermeldung vom Programm:
"Es werden nur 24-Bit Bitmaps unterstützt!"