VB 5/6-Tipp 0626: Helligkeitsänderung in Grafiken per ASM
von Udo Schmidt
Beschreibung
Dieser Tipp stammt aus eine Reihe von Tipps rund um das Thema Grafikmanipulation mit ASM. Das Modul "asm_001ROU.bas" ist daher in allen Tipps das Gleiche. In diesem Tipp wird gezeigt, wie man die Helligkeit eines Bildes ändert. Dabei wird sowohl eine Lösung mit VB, wie auch eine Lösung in ASM (der Code liegt bei) angeboten.
Schwierigkeitsgrad: | Verwendete API-Aufrufe: CLSIDFromString, CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), CreateDIBSection, OleCreatePictureIndirect (CreatePic), DeleteObject, GetDC, GetDIBits, GetObjectA (GetObject), ReleaseDC | 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 prjBrightness.vbp ---------- ' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt. '--- Anfang Formular "frm_Brightness" alias frm_Brightness.frm --- ' Steuerelement: Schaltfläche "Command3" ' Steuerelement: Standarddialog-Steuerelement "CommonDialog1" ' Steuerelement: Schaltfläche "Command2" ' Steuerelement: Schaltfläche "Command1" ' Steuerelement: Horizontale Scrollbar "HScroll1" ' Steuerelement: Bildfeld-Steuerelement "Picture1" '--------------------------------------------------------------------------------------- ' (softKUS) - VIII/2003 '--------------------------------------------------------------------------------------- ' Die Funktion "Brightness" ändert die Helligkeit eines Bildes. ' ' Für die Umsetzung wird eine Assembler-(Maschinensprache)-Routine benutzt, ' deren Funktionsweise nicht ohne weiteres ersichtlich ist. Deshalb ist eine ' Basic-Funktion, basBrightness, angefügt. Per Mausklick auf Command3 kann ' zwischen Basic- und Assemblerbenutzung hin- und hergeschaltet werden. ' ' Das Beispiel besteht aus drei Modulen: ' 1. Form1 - Dient bloß zur Demonstration ' 2. Module1 - Enthält grundlegendes zum Lesen/Schreiben der Bilder ' 3. Module2 - Enthält die eigentliche Bildbearbeitung (asmBrightness/basBrightness) ' ' Die ASM-Routine, asmBrightness, kann auch völlig losgelöst vom hiesigen Rahmen ' benutzt werden. Es muß lediglich gewährleistet sein, daß der erste Parameter ' (lpAsmBmpPara) auf eine genau nach unten beschriebenem Muster erstellte und ' mit gültigen Werten initialisierte Struktur verweist - andernfalls kommt ' es ' garantiert zum PC-Absturz. ' '--------------------------------------------------------------------------------------- ' ' Ein Formular mit: ' Picture1, Command1 bis Command3, HScroll1, CommonDialog1 ' '--------------------------------------------------------------------------------------- Option Explicit Option Base 0 ' * ' ** ' *** Konstanten ' *** - für die Bildbearbeitung sind nur die Parameter für die Bildlaufleiste ' *** interessant (HPar): Min;Max;(Standard-)Value;SmallChange;LargeChange ' ** ' * ' größerer Wert => größere Form Private Const XYcm As Long = 567 Private Const Ftxt As String = "asm-Beispiel Brightness" Private Const HPar As String = "-0255;00255;00000;00001;00010" ' * ' ** ' *** Variablen ' ** ' * ' log: Bildlaufleiste aktiv J/N Dim scrH_flg As Boolean ' lng: Bildlaufleisten-Standardwert Dim scrH_std As Long ' udt: Datenstruktur für ASM-Routine Dim abp As asmBmpPara ' bin: Bilddaten Dim src() As Byte ' bin: Puffer für die Bildbearbeitung Dim tgt() As Byte ' log: .T.=Assember, .F.=Basic Dim pmd As Boolean Private Sub Form_Load() ' Initialisieren der Byte-Arrays ReDim src(1, 1) ' (vermeidet Zugriffsfehler) ReDim tgt(1, 1) With Me .ScaleMode = vbTwips .Width = (Me.Controls.Count * 2 - 2) * XYcm .Height = (Me.Controls.Count * 2 - 2) * XYcm .Caption = Ftxt End With With HScroll1 .Min = Val(Mid$(HPar, 1, 5)) .Max = Val(Mid$(HPar, 7, 5)) .Value = Val(Mid$(HPar, 13, 5)) .SmallChange = Val(Mid$(HPar, 19, 5)) .LargeChange = Val(Mid$(HPar, 25, 5)) scrH_std = .Value End With Command1.Caption = "Bild laden" Command2.Caption = "Undo" Command3.Caption = "Basic" Picture1.ScaleMode = vbTwips pmd = True End Sub ' dummy Bild erzeugen Private Sub Form_Initialize() Dim X1 As Long Randomize Timer Picture1.AutoRedraw = True For X1 = 1 To 400 Picture1.DrawWidth = 1 + Rnd() * 30 Picture1.Line (Rnd * Picture1.Width, Rnd * Picture1.Height)-(Rnd * Picture1.Width, _ Rnd * Picture1.Height), RGB(Rnd * 255, Rnd * 255, Rnd * 255) Next X1 Picture1.AutoRedraw = False scrH_flg = ReadData(Picture1.Image, abp, src, tgt, pmd, False) If scrH_flg Then WriteData Picture1, abp.src, True End Sub Private Sub Form_Resize() Dim dfw As Long Dim dfh As Long Dim tmp As Long dfw = Me.Width - Me.ScaleWidth dfh = Me.Height - Me.ScaleHeight tmp = ((Me.Controls.Count - 3) * 2.25 + 0.25) * XYcm + dfw If Me.Width < tmp Then Me.Width = tmp If Me.Height < 5 * XYcm Then Me.Height = 5 * XYcm With Command1 ' Bild laden .Top = 0.25 * XYcm .Left = 0.25 * XYcm .Width = 2 * XYcm .Height = 0.5 * XYcm End With With Command2 ' Undo .Top = 0.25 * XYcm .Left = Me.Width - 4.5 * XYcm - dfw .Width = 2 * XYcm .Height = 0.5 * XYcm End With With Command3 ' bas/asm .Top = 0.25 * XYcm .Left = Me.Width - 2.25 * XYcm - dfw .Width = 2 * XYcm .Height = 0.5 * XYcm End With With Picture1 .Top = 1 * XYcm .Left = 0.25 * XYcm .Width = Me.Width - 0.5 * XYcm - dfw .Height = Me.Height - 2 * XYcm - dfh End With With HScroll1 .Top = Picture1.Top + Picture1.Height + 0.25 * XYcm .Left = 0.25 * XYcm .Width = Picture1.Width .Height = 0.5 * XYcm End With End Sub Private Sub Picture1_DblClick() Form_Initialize End Sub ' Bild laden Private Sub Command1_Click() ' obj: enthält das zu ladende Bild Dim pic As IPicture On Error Resume Next With CommonDialog1 .CancelError = True .Flags = &H281800 .Filter = "Bilder |*.bmp;*.jpg||" .ShowOpen If Err = 0 Then Set pic = LoadPicture(.FileName) If pic Is Nothing Then MsgBox "Bild konnte nicht geladen werden" ElseIf ReadData(pic, abp, src, tgt, pmd) Then ' alles okay => setze pic auf die PictureBox Set Picture1.Picture = pic ' setze HScroll1 auf den Standardwert Command2_Click scrH_flg = True End If End If End With Picture1.SetFocus End Sub ' Undo Private Sub Command2_Click() ' Bildlaufleiste deaktivieren scrH_flg = False ' Änderung am Bild zurücknehmen WriteData Picture1, abp.src ' Bildlaufleiste auf Ausgangswert HScroll1 = scrH_std ' Bildlaufleiste aktivieren scrH_flg = True Picture1.SetFocus End Sub ' Umschalten zw. bas und asm Private Sub Command3_Click() pmd = Not pmd Command3.Caption = Choose(pmd + 2, "Basic", "Assembler") If pmd = False And Picture1.Picture.Handle <> 0 And VarPtr(tgt(1, 1)) <> abp.tgt.bmBits _ Then ' Wenn abp.tgt direkt auf den Speicher der Bitmap ' weist, muss für die Basic-Routine auf ein ByteArray ' umgelenkt werden. Dazu kann auch mit einer SAVEARRAY- ' Struktur gearbeitet werden - das führte hier aber zu weit. ReDim tgt(1 To UBound(src, 1), 1 To UBound(src, 2)) abp.tgt.bmBits = VarPtr(tgt(1, 1)) End If Picture1.SetFocus End Sub Private Sub HScroll1_Scroll() HScroll1_Change End Sub Private Sub HScroll1_Change() Dim B1 As Boolean If scrH_flg = False Or Picture1.Picture.Handle = 0 Then ' deaktiviert/kein Bild geladen => ignorieren ElseIf pmd Then B1 = asmBrightness(VarPtr(abp), HScroll1) Else B1 = basBrightness(src, tgt, HScroll1) End If ' geändertes Bild ausgeben If B1 Then WriteData Picture1, abp.tgt End Sub '--- Ende Formular "frm_Brightness" alias frm_Brightness.frm --- '--- Anfang Modul "asm_Brightness" alias asm_Brightness.bas --- Option Explicit ' asmBrightness ' ' CALL asmBrightness(ptr:lpAsmBmpPara, [fct:factor]) ' ' IN: lng:ptr Points to asmBmpPara-structure ' lng:fct -255 to 255 (default = 10) ' ' OUT: bol success ' Function asmBrightness(lpAsmBmpPara As Long, Optional fct As Long = 10) As _ Boolean Static asm(23) As Long If asm(0) = 0 Then asm(0) = &HEC8B5590 asm(1) = &H8B575653 asm(2) = &H758B107D asm(3) = &HBC68B0C asm(4) = &HF70779F6 asm(5) = &H1B8DE asm(6) = &HB90000 asm(7) = &H2B000001 asm(8) = &HF73473F1 asm(9) = &H78899D6 asm(10) = &H2D60347 asm(11) = &H49F48AC6 asm(12) = &H5D8BF475 asm(13) = &H14738B08 asm(14) = &H8B2C7B8B asm(15) = &HAF0F1C4B asm(16) = &H5D8B204B asm(17) = &HC1D7AD10 asm(18) = &HC1D708C8 asm(19) = &HC1D708C8 asm(20) = &H49AB10C8 asm(21) = &H1BF9EF75 asm(22) = &H5B5E5FC0 asm(23) = &H10C25D End If ' ************************************************************ Dim bar(255) As Byte asmBrightness = CallWindowProc(asm(0), lpAsmBmpPara, fct, VarPtr(bar(0)), _ 0) End Function ' basBrightness ' ' AUFRUF: basBrightness(src, tgt, [fct:Faktor]) ' ' EIN: bar:src Herkunftsdaten (ByteArray) ' bar:tgt Zieldaten (ByteArray) ' lng:fct Faktor -255 bis 255 (Vorgabe 10) ' ' AUS: log Erfolg ' Function basBrightness(src() As Byte, tgt() As Byte, Optional fct As Long = _ 10) As Boolean ' Zähler Dim X1 As Long ' Zähler Dim Y1 As Long Dim N1 As Long Dim N2 As Long Dim N3 As Long 'bar: Ersetzungstabelle Dim bar(255) As Byte If Abs(fct) > 255 Then MsgBox "invalid parameter fct" & fct Else N1 = 255 - Abs(fct) N2 = IIf(fct > 0, fct, 1) ' Ersetzungstabelle erstellen For X1 = 0 To 255 bar(X1) = N2 N3 = N3 + N1 N2 = N2 - (N3 > 256) N3 = N3 And 255 Next X1 ' Werte ersetzen For Y1 = 1 To UBound(src, 2) For X1 = 1 To UBound(src, 1) Step 4 tgt(X1 + 0, Y1) = bar(src(X1 + 0, Y1)) tgt(X1 + 1, Y1) = bar(src(X1 + 1, Y1)) tgt(X1 + 2, Y1) = bar(src(X1 + 2, Y1)) Next X1 Next Y1 basBrightness = True End If End Function '--- Ende Modul "asm_Brightness" alias asm_Brightness.bas --- '------ Anfang Modul "asm_001ROU" alias asm_001ROU.bas ------ Option Explicit Option Base 0 ' * ' ** ' *** Konstanten ' ** ' * ' gdi/ole Private Const S_OK As Long = 0 Private Const BI_RGB As Long = 0 Private Const DIB_RGB_COLORS As Long = 0 Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300" & _ "CAB}" ' * ' ** ' *** Strukturen ' ** ' * ' Windows-Standard ' udt: Windows-Bitmap-Struktur Public Type BITMAP '-> Einlesen der Bildinformationen 'mit GDI_GetObject() bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type ' udt: Windows-Bitmap-Struktur Public Type BITMAPINFOHEADER '-> Erstellen von Bildern im Speicher, 'mit GDI_CreateDibSection biSize As Long biWidth As Long biHeight As Long '-> Einlesen von Bilddaten (binär) 'mit GDI_GetDiBits biPlanes As Integer biBitCount As Integer ' 'wird nur als Unterstruktur von 'BITMAPINFO benötigt (s.u.) biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type ' udt: Windows-Bitmap-Struktur Public Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As Long End Type ' udt: PictureDescription Private Type PictDesc '-> Erstellen eines IPicture-Objektes 'mit OleCreatePictureIndirect cbSizeofStruct As Long picType As Long hImage As Long xExt As Long yExt As Long End Type ' von asm-Routinen genutzte Struktur ' udt: AsmStruktur Public Type asmBmpPara '-> fasst Infos über Herkunftsdaten 'und Zieldaten zusammen 'dient vor allem dazu, die Anzahl 'der Funktionsparamter zu begrenzen src As BITMAP tgt As BITMAP srcExpansion As Long End Type ' * ' ** ' *** Externe Funktionen ' ** ' * ' div ' hiermit werden Daten recht schnell kopiert Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest _ As Any, ByRef hpvSource As Any, ByVal cbCopy As Long) ' hiermit wird die asm-Routine aufgerufen Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByRef lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal _ wParam As Long, ByVal lParam As Long) As Long ' GDI (graphical device interface) ' Erstellen eines Gerätekontextes Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) _ As Long ' Freigeben eines Gerätekontextes Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd _ As Long, ByVal hDC As Long) As Long ' Einlesen von Informationen über GDI-Objekte (z.B. Bilder) Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject _ As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long ' Löschen eines GDI-Objektes Private Declare Function DeleteObject Lib "gdi32" (ByVal _ hObject As Long) As Long ' Erstellen eines geräte-unabhängigen Bildes (Device Independent Bitmap, DIB) Private Declare Function CreateDIBSection Lib "gdi32" _ (ByVal hDC As Long, ByRef pbmi As BITMAPINFO, ByVal iUsage As Long, ByRef _ ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long ' Einlesen binärer Bilddaten Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC _ As Long, ByVal hBM As Long, ByVal uStartScan As Long, ByVal cScanLines As Long, _ ByRef lpvBits As Any, ByRef lpBmi As BITMAPINFO, ByVal uUsage As Long) As Long ' OLE (Object Linked Embedding, heute: COM oder ActiveX genannt) ' Umwandeln eines CLSID-Strings in Binärcode Private Declare Function CLSIDFromString Lib "ole32" _ (ByVal lpszProgID As Long, ByVal pCLSID As Long) As Long ' Erstellen eines IPicture-Objektes aus einem GDI-Bitmap-Handle Private Declare Function CreatePic Lib "olepro32" Alias "OleCreatePictureIndirect" _ (ByRef lpPictDesc As PictDesc, ByVal riid As Long, ByVal fPictureOwnsHandle _ As Long, ByRef ipic As IPicture) As Long Function ReadData(pic As IPicture, abp As asmBmpPara, src() As Byte, tgt() As Byte, _ Optional pmd As Boolean = True, Optional eMD As Boolean = True) As Boolean ' infos über das einzulesende Bild Dim bmp As BITMAP ' erweiterte infos über das einzulesende Bild Dim bmi As BITMAPINFO ' Gerätekontext-Handle Dim hDC As Long ' Zeiger auf die binären Bilddaten Dim ptr As Long Dim tmp As Long ' Einlesen der Bitmapinfos If GetObject(pic.Handle, Len(bmp), bmp) = 0 Then If eMD Then MsgBox "Bildinformationen konnten nicht gelesen werden" ElseIf pmd = True And bmp.bmBits <> 0 And bmp.bmBitsPixel = 32 Then ' wenn die Daten im richtigen Format vorliegen, diesen Pointer nehmen ptr = bmp.bmBits Else ' sonst per GDI-Funktion konvertieren lassen und im tgt-bArray() speichern With bmi.bmiHeader .biSize = Len(bmi.bmiHeader) .biCompression = BI_RGB .biHeight = bmp.bmHeight .biWidth = bmp.bmWidth .biPlanes = 1 .biBitCount = 32 .biSizeImage = .biWidth * 4 * .biHeight ReDim tgt(1 To .biWidth * 4, 1 To .biHeight) hDC = GetDC(0) If hDC = 0 Then If eMD Then MsgBox "Gerätekontext konnte nicht erzeugt werden" ElseIf GetDIBits(hDC, pic.Handle, 0, .biHeight, tgt(1, 1), bmi, DIB_RGB_COLORS) _ Then ptr = VarPtr(tgt(1, 1)) Else ' bei Fehler: tgt-bArray wieder auf usrprüngliche Dimension setzen ReDim tgt(1 To UBound(src, 1), 1 To UBound(src, 2)) If eMD Then MsgBox "Bilddaten konnten nicht gelesen werden" End If If hDC Then ReleaseDC 0, hDC End With End If If ptr Then bmp.bmBitsPixel = 32 bmp.bmWidthBytes = bmp.bmWidth * 4 tmp = bmp.bmWidthBytes * bmp.bmHeight 'src-bArray dimensionieren und mit Bilddaten füllen ReDim src(1 To bmp.bmWidthBytes, 1 To bmp.bmHeight) CopyMemory src(1, 1), ByVal ptr, tmp 'asmBmpPara-Struktur setzen abp.src = bmp abp.src.bmBits = VarPtr(src(1, 1)) abp.tgt = bmp abp.tgt.bmBits = ptr ReadData = True End If End Function Function WriteData(pbx As PictureBox, bmp As BITMAP, Optional force As Boolean _ = False) As Boolean 'Neues Picture-Objekt Dim pic As IPicture 'infos über das zu überschreibende Bild Dim tmp As BITMAP 'erw. infos über das Bild Dim bmi As BITMAPINFO 'info zum Erstellen eines neuen Pictures Dim dsc As PictDesc 'temporär benutzter Gerätekontext Dim hDC As Long 'Zeiger auf die binären Bilddaten Dim ptr As Long Dim flg As Long 'clsid des IPicture-Objektes Dim iid(15) As Byte flg = pbx.Picture.Handle And (force = False) If flg Then flg = GetObject(flg, Len(tmp), tmp) If bmp.bmBits = tmp.bmBits Then 'tgt weist direkt auf den Bildobjekt-Speicher => nothing to do pbx.Refresh WriteData = True ElseIf flg > 0 And tmp.bmBits <> 0 And bmp.bmWidth = tmp.bmWidth And bmp.bmHeight _ = tmp.bmHeight And bmp.bmBitsPixel = tmp.bmBitsPixel Then ' wenn das Ziel dasselbe Datenformat aufweist, einfach kopieren CopyMemory ByVal tmp.bmBits, ByVal bmp.bmBits, bmp.bmWidthBytes * bmp.bmHeight pbx.Refresh WriteData = True Else ' sonst per OLE-Funktion ein neues IPicture-Objekt erstellen dsc.cbSizeofStruct = Len(dsc) dsc.picType = vbPicTypeBitmap With bmi.bmiHeader .biSize = Len(bmi.bmiHeader) .biCompression = BI_RGB .biBitCount = 32 .biHeight = bmp.bmHeight .biWidth = bmp.bmWidth .biPlanes = 1 .biSizeImage = bmp.bmWidthBytes * bmp.bmHeight End With ' 1. Gerätekontext hDC = GetDC(0) ' 2. DIB-Section If hDC Then dsc.hImage = CreateDIBSection(hDC, bmi, DIB_RGB_COLORS, ptr, 0, _ 0) If hDC = 0 Then MsgBox "Gerätekontext konnte nicht erzeugt werden" ElseIf dsc.hImage = 0 Or ptr = 0 Then MsgBox "Bildkopie konnte nicht erstellt werden" Else CopyMemory ByVal ptr, ByVal bmp.bmBits, bmp.bmWidthBytes * bmp.bmHeight If CLSIDFromString(StrPtr(IID_IPicture), VarPtr(iid(0))) <> S_OK Then MsgBox "OLE Fehler" ' 3. IPicture-Objekt ElseIf CreatePic(dsc, VarPtr(iid(0)), True, pic) <> S_OK Then MsgBox "OLE picture creation error" Else ' ... und das Ergebnis auf die PictureBox setzen Set pbx.Picture = Nothing Set pbx.Picture = pic dsc.hImage = 0 WriteData = True End If End If If hDC Then ReleaseDC 0, hDC If dsc.hImage Then DeleteObject dsc.hImage End If End Function '------- Ende Modul "asm_001ROU" alias asm_001ROU.bas ------- '----------- Ende Projektdatei prjBrightness.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.