VB 5/6-Tipp 0653: Bitmaps drehen per ASM
von Udo Schmidt
Beschreibung
Dieser Tipp ermöglicht das freie Drehen von Grafiken in atemberaubender Geschwindigkeit.
Durch Auswahl einer Maskenfarbe kann der Hintergrundbereich optimiert werden.
Zudem ist eine Glättung implementiert.
| Schwierigkeitsgrad:
| Verwendete API-Aufrufe: RtlMoveMemory (API_CopyByRef), GetDC (API_GetDC), ReleaseDC (API_ReleaseDC), CallWindowProcA (ASM_cdByRef), CreateDIBSection (GDI_CreateDIB), DeleteObject (GDI_DeleteObject), GetDIBits (GDI_GetDIBits), GetObjectA (GDI_GetObject), CLSIDFromString (OLE_CLSIDFromString), OleCreatePictureIndirect (OLE_CreatePic), VarPtr (VB6_ArrayPointer) | 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 Projekt1.vbp ------------- ' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt. '--------- Anfang Formular "Form1" alias Form1.frm --------- ' Steuerelement: Kontrollkästchen-Steuerelement "Check1" (Index von 0 bis 5) ' Steuerelement: Bildfeld-Steuerelement "Picture1" ' Steuerelement: Horizontale Scrollbar "HScroll1" (Index von 0 bis 2) ' Steuerelement: Schaltfläche "Command1" (Index von 0 bis 1) ' Steuerelement: Standarddialog-Steuerelement "CommonDialog1" ' Steuerelement: Beschriftungsfeld "Label1" (Index von 0 bis 3) Option Base 0 Option Explicit Option Compare Text Const xCM As Long = 567 ' twips to cm Const stdW As Long = 12 ' standard width Const stdH As Long = 6 ' standard height Const cmd_pic As Long = 0 ' command: load picture Const cmd_pmd As Long = 1 ' command: change mode Const chk_aa As Long = 0 ' antiA Const chk_msk As Long = 1 ' auto mask (1st pix/bmp) Const chk_use As Long = 2 ' use mask Const chk_fil As Long = 3 ' fill mask Const chk_cut As Long = 4 ' cut result Const chk_adj As Long = 5 ' adjust result Const lbl_hgt As Long = 0 ' label: bmp height Const lbl_wid As Long = 1 ' label: bmp width Const lbl_ang As Long = 2 ' label: bmp angle Const lbl_msk As Long = 3 ' label: mask color Const scr_hgt As Long = 0 ' HScrBar: bmp height Const scr_wid As Long = 1 ' HScrBar: bmp width Const scr_ang As Long = 2 ' HScrBar: bmp angle Dim org As StdPicture ' original picture Dim flg_ini As Boolean ' form initialized? Dim flg_pmd As Boolean ' .T.: asm, .F.: bas Private Sub Check1_Click(Index As Integer) HScroll1_Change 0 End Sub Private Sub Command1_Click(Index As Integer) Select Case Index Case cmd_pic: getPIC Case cmd_pmd: swpRMD End Select If flg_ini Then Picture1.SetFocus End Sub Private Sub Form_Activate() HScroll1_Change 0 End Sub Private Sub Form_Load() Me.Width = stdW * xCM Me.Height = stdH * xCM With HScroll1(scr_hgt) .Min = 20: .Max = 300 .SmallChange = 1: .LargeChange = 10 .Value = 100 End With With HScroll1(scr_wid) .Min = 20: .Max = 300 .SmallChange = 1: .LargeChange = 10 .Value = 100 End With With HScroll1(scr_ang) .Min = 0: .Max = 3600 .SmallChange = 1: .LargeChange = 50 .Value = 0 End With Check1(chk_aa).Caption = "Glätten" Check1(chk_msk).Caption = "AutoMsk" Check1(chk_use).Caption = "UseMask" Check1(chk_fil).Caption = "FillMsk" Check1(chk_cut).Caption = "Abschneiden" Check1(chk_adj).Caption = "Anpassen" Check1(chk_fil).Value = 1 Check1(chk_adj).Value = 1 With Label1(lbl_msk) .Caption = "MaskColor" .BackColor = 12615935 .ForeColor = 0 End With Command1(cmd_pic).Caption = "Bild laden" Command1_Click cmd_pmd HScroll1_Scroll 0 End Sub Private Sub Form_Resize() Dim C1 As Control Dim C2 As Control Dim I1 As Long Dim N1 As Long Dim bdr As Long bdr = 0.25 * xCM If ScaleHeight = 0 Then ' just minimizing Else ' min width/height I1 = 12 * xCM + 4 * bdr If Width < I1 Then Width = I1 + Width - ScaleWidth I1 = Check1.Count + Label1.Count + Command1.Count I1 = I1 / 2 * xCM + 6 * bdr If Height < I1 Then Height = I1 + Height - ScaleHeight ' checkboxes For I1 = 0 To Check1.Count - 1 Set C1 = Check1(I1) C1.Height = 0.5 * xCM C1.Width = 2.5 * xCM C1.Left = bdr C1.Top = bdr + I1 / 2 * xCM Next ' scrollbars/labels N1 = C1.Top + C1.Height + 2 * bdr For I1 = 0 To HScroll1.Count - 1 Set C2 = Label1(I1) C2.Top = N1 + I1 * C1.Height C2.Left = bdr C2.Width = IIf(I1 = lbl_msk, 4 * xCM, C1.Width) C2.Height = C1.Height Set C2 = HScroll1(I1) C2.Top = N1 + I1 * C1.Height + 0.05 * xCM C2.Left = C1.Left + C1.Width + bdr C2.Width = 4 * xCM C2.Height = 0.4 * xCM Next Label1(lbl_msk).Top = Check1(chk_msk).Top Label1(lbl_msk).Left = HScroll1(scr_hgt).Left With Command1(0) Set C2 = HScroll1(scr_ang) .Top = C2.Top + C2.Height + 2 * bdr .Left = C2.Left .Width = C2.Width .Height = C1.Height For I1 = 1 To Command1.Count - 1 Command1(I1).Top = .Top + I1 * .Height Command1(I1).Left = .Left Command1(I1).Width = .Width Command1(I1).Height = .Height Next End With With Picture1 .Top = bdr .Left = 6.5 * xCM + 3 * bdr .Width = Me.ScaleWidth - .Left - bdr .Height = Me.ScaleHeight - 2 * bdr End With End If End Sub Private Function getPIC() 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" Else Set org = pic Set Picture1.Picture = org flg_ini = True HScroll1_Change scr_ang End If End If End With End Function Private Sub HScroll1_Change(Index As Integer) HScroll1_Scroll Index End Sub Private Sub HScroll1_Scroll(Index As Integer) Dim tgt As StdPicture Dim flg As Boolean Label1(lbl_hgt).Caption = _ "Höhe " & HScroll1(scr_hgt) & " %" Label1(lbl_wid).Caption = _ "Breite " & HScroll1(scr_wid) & " %" Label1(lbl_ang).Caption = _ "Winkel " & HScroll1(scr_ang) / 10 & "°" If flg_ini And (Not org Is Nothing) Then If flg_pmd Then flg = asmRotate(org, _ tgt, _ HScroll1(scr_ang) / 10, _ HScroll1(scr_wid) / 100, _ HScroll1(scr_hgt) / 100, _ Check1(chk_cut).Value, _ Check1(chk_adj).Value, _ Check1(chk_aa).Value, _ 0.5, _ Check1(chk_use).Value, _ Label1(lbl_msk).BackColor, _ Check1(chk_msk).Value, _ Check1(chk_fil).Value) Else flg = basRotate(org, _ tgt, _ HScroll1(scr_ang) / 10, _ HScroll1(scr_wid) / 100, _ HScroll1(scr_hgt) / 100, _ Check1(chk_cut).Value, _ Check1(chk_adj).Value, _ Check1(chk_aa).Value, _ 0.5, _ Check1(chk_use).Value, _ Label1(lbl_msk).BackColor, _ Check1(chk_msk).Value, _ Check1(chk_fil).Value) End If If flg Then Set Me.Picture1.Picture = tgt End If End Sub Private Sub Label1_Click(Index As Integer) On Error Resume Next If Index = lbl_msk Then With CommonDialog1 .CancelError = True .Color = Label1(lbl_msk).BackColor .ShowColor If Err = 0 Then Label1(lbl_msk).BackColor = .Color Label1(lbl_msk).ForeColor = .Color Xor &HC0C0C0 HScroll1_Change scr_hgt End If End With End If End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Label1(lbl_msk).BackColor = Picture1.Point(X, Y) Label1(lbl_msk).ForeColor = Picture1.Point(X, Y) Xor &HC0C0C0 HScroll1_Change scr_hgt End Sub Private Function swpRMD() flg_pmd = Not flg_pmd Command1(cmd_pmd).Caption = IIf(flg_pmd, "Basic", "Assembler") End Function '---------- Ende Formular "Form1" alias Form1.frm ---------- '---------- Anfang Modul "bmpROU" alias bmpROU.bas ---------- '--------------------------------------------------------------------------------------- ' Module : bmpROU ' Author : (softKUS) - VII/2004 ' Purpose : routines for converting bitmaps to arrays and vice versa ' by adapting bpp to the required value ' ' Hints - You may use this code in your programs at your own risk ' - You may not publish/sell it without the authour's agreement ' ' - If you have suggestions for improvements or corrections, ' please do not hesitate to email them to info@softkus.de '--------------------------------------------------------------------------------------- Option Explicit ' *** ' Konstanten ' *** Public Const S_OK As Long = 0 Public Const BI_RGB As Long = 0 Public Const DIB_RGB_COLORS As Long = 0 Public Const dWord As Long = 4 Public Const var_pvData As Long = 8 Public Const sar_pvData As Long = 12 Public Const IID_IPicture As String = _ "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" ' *** ' Typen ' *** ' udt: Windows-Bitmap-Struktur ' -> Einlesen der Bildinformationen ' mit GDI_GetObject() Public 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 ' udt: Windows-Bitmap-Struktur ' -> Erstellen von Bildern im Speicher, ' mit GDI_CreateDibSection ' -> Einlesen von Bilddaten (binär) ' mit GDI_GetDiBits ' ' wird nur als Unterstruktur von ' BITMAPINFO benötigt (s.u.) Public Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer 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 ' -> Erstellen eines IPicture-Objektes ' mit OleCreatePictureIndirect Public Type PictDesc cbSizeofStruct As Long picType As Long hImage As Long xExt As Long yExt As Long End Type ' udt: VB-Array-Struktur ' -> Setzen eines Bytearrays ' gemäß vorhandener Daten ' mit BMP2ARR ' ' !!! Das Bytearray muß nach ' Verwednung wieder auf ' einen Nullpointer gesetzt ' werden, sonst stürzt VB ab Public Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Dim1UBound As Long Dim1LBound As Long Dim2UBound As Long Dim2LBound As Long End Type ' von asm-Routinen genutzte Struktur ' udt: AsmStruktur ' -> fasst Infos über Herkunftsdaten ' und Zieldaten zusammen ' dient vor allem dazu, die Anzahl ' der Funktionsparamter zu begrenzen Public Type asmBmpPara src As BITMAP tgt As BITMAP srcExpansion As Long End Type ' *** ' Externe Funktionen ' *** ' ----------------------------------------------------- ' MIS ' ----------------------------------------------------- Public Declare Sub API_CopyByRef _ Lib "kernel32" Alias "RtlMoveMemory" _ (ByRef hpvDest As Any, _ ByRef hpvSource As Any, _ ByVal cbCopy As Long) Public Declare Function VB6_ArrayPointer _ Lib "msvbvm60" Alias "VarPtr" _ (arr() As Any) As Long Public Declare Function ASM_cdByRef _ Lib "user32" Alias "CallWindowProcA" _ (ByRef asm As Any, _ ByRef PA1 As Any, _ ByRef PA2 As Any, _ ByRef PA3 As Any, _ ByRef PA4 As Any) As Long ' ----------------------------------------------------- ' GDI (graphical device interface) ' ----------------------------------------------------- ' Handle auf Fenster-Gerätekontext Public Declare Function API_GetDC _ Lib "user32" Alias "GetDC" _ (ByVal hWnd As Long) As Long ' Freigeben eines Gerätekontextes Public Declare Function API_ReleaseDC _ Lib "user32" Alias "ReleaseDC" _ (ByVal hWnd As Long, _ ByVal hDC As Long) As Long ' Einlesen von Informationen über GDI-Objekte (z.B. Bilder) Public Declare Function GDI_GetObject _ Lib "gdi32" Alias "GetObjectA" _ (ByVal hObject As Long, _ ByVal nCount As Long, _ ByRef lpObject As Any) As Long ' Einlesen binärer Bilddaten Public Declare Function GDI_GetDIBits _ Lib "gdi32" Alias "GetDIBits" _ (ByVal hDC As Long, _ ByVal hBM As Long, _ ByVal uStartScan As Long, _ ByVal cScanLines As Long, _ ByVal lpvBits As Long, _ ByRef lpbmi As BITMAPINFO, _ ByVal uUsage As Long) As Long ' Erstellen eines geräte-unabhängigen Bildes ' (Device Independent Bitmap, DIB) Public Declare Function GDI_CreateDIB _ Lib "gdi32" Alias "CreateDIBSection" _ (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 ' Löschen eines GDI-Objektes Public Declare Function GDI_DeleteObject _ Lib "gdi32" Alias "DeleteObject" _ (ByVal hObject As Long) As Long ' ----------------------------------------------------- ' OLE (Object Linked Embedding, heute: COM oder ActiveX genannt) ' ----------------------------------------------------- ' Umwandeln eines CLSID-Strings in Binärcode Public Declare Function OLE_CLSIDFromString _ Lib "ole32" Alias "CLSIDFromString" _ (ByVal lpszProgID As Long, _ ByRef pCLSID As Any) As Long ' Erstellen eines IPicture-Objektes aus einem GDI-Bitmap-Handle Public Declare Function OLE_CreatePic _ Lib "olepro32" Alias "OleCreatePictureIndirect" _ (ByRef lpPictDesc As PictDesc, _ ByRef riid As Any, _ ByVal fPictureOwnsHandle As Long, _ ByRef ipic As IPicture) As Long ' ARR2BMP Convert array to bitmap ' ' CALL: ARR2BMP(arr, bmi, @hMB) ' ' IN: udt:bmi BitmapInfo structure ' var:arr Array to be converted ' lng:hBM Placeholder for bitmap handle ' ' OUT: bol success ' Function ARR2BMP( _ arr, _ bmi As BITMAPINFO, _ hBM As Long) As Boolean ' info zum Erstellen eines neuen Pictures Dim dsc As PictDesc ' temporär benutzter Gerätekontext Dim hDC As Long ' Zeiger auf die binären Bildpuffer Dim ptr As Long ' Zeiger auf den Arraypuffer Dim adr As Long ' Init (array pointer ermitteln) hBM = 0 arrINF arr, adr If adr Then hDC = API_GetDC(0) If hDC Then hBM = GDI_CreateDIB(hDC, bmi, DIB_RGB_COLORS, ptr, 0, 0) ' ungültiges Array If adr = 0 Then ' Gerätekontext konnte nicht ermitelt werden ElseIf hDC = 0 Then ' Bildkopie konnte nicht erstellt werden ElseIf hBM = 0 Or ptr = 0 Then If hBM Then GDI_DeleteObject hBM Else API_CopyByRef ByVal ptr, ByVal adr, bmi.bmiHeader.biSizeImage ARR2BMP = True End If If hDC Then API_ReleaseDC 0, hDC End Function ' ARR2PIC Convert array to StdPicture ' ' CALL: ARR2PIC(arr, bmi, @tgt) ' ' IN: var:arr Array to be converted ' udt:bmi BitmapInfo structure ' pic:tgt Standardpicture object to be set ' ' OUT: bol success ' Function ARR2PIC( _ arr, _ bmi As BITMAPINFO, _ tgt As StdPicture) As Boolean Dim hBM As Long If ARR2BMP(arr, bmi, hBM) Then ARR2PIC = BMP2PIC(hBM, tgt, True) End Function ' arrINF Get array information ' ' CALL: arrINF(arr, [@adr:lpData]) ' ' IN: var:arr Array ' lng:adr Placeholder for data-pointer ' ' OUT: lng Pointer to array structure Function arrINF( _ arr As Variant, _ Optional lpData As Long) As Long Dim ptr As Long If IsArray(arr) Then API_CopyByRef ptr, ByVal VarPtr(arr) + var_pvData, dWord If ptr Then API_CopyByRef ptr, ByVal ptr, dWord If ptr Then API_CopyByRef lpData, ByVal ptr + sar_pvData, dWord arrINF = ptr End If End Function ' BMP2ARR Convert bitmap to array ' ' CALL: BMP2ARR(hBM, @bmi, @sar, @arr, [bpp], [cnt:dims]) ' ' IN: lng:hBM Bitmap handle ' var:arr Array to be filled (byte v integer v long) ' udt:bmi Bitmapinfo (to be filled with hBM-Info) ' udt:sar Savearray structure ' lng:bpp BitsPerPixel (dflt=24) ' lng:cnt Number of dimensions (dflt=2) ' ' OUT: bol success ' ' Caution: If hBM matches the required color format and its ' data-pointer can be get, then sar is set acc., ' arr points directly to the originally data. This ' link has to be deleted before VB destroys arr! ' If hBM does not match the requirements, arr is ' set physically. sar.pvData equals to 0 and no ' further action has to be taken, because arr will ' be automatically destroyed correctly by VB. ' Function BMP2ARR( _ hBM As Long, _ arr, _ bmi As BITMAPINFO, _ sar As SAFEARRAY2D, _ Optional bpp As Long = 24, _ Optional dims As Long = 2, _ Optional X1 As Long = 0, _ Optional Y1 As Long = 0, _ Optional XN As Long = -1, _ Optional YN As Long = -1) As Boolean Dim bmp As BITMAP Dim dmy As SAFEARRAY2D Dim hDC As Long Dim fct As Long Dim ptr As Long Dim tmp As Long Dim flg As Boolean On Error Resume Next Select Case VarType(arr) Case vbArray Or vbByte: fct = 1 Case vbArray Or vbInteger: fct = 2 Case vbArray Or vbLong: fct = 4 End Select If fct = 0 Then MsgBox "Ungültiger Arraytyp" ElseIf GDI_GetObject(hBM, Len(bmp), bmp) = 0 Then MsgBox "Bildinformationen konnten nicht gelesen werden" Else flg = ((X1 Or XN) = 0) And ((Y1 And YN) = -1) tmp = (bpp / 8# * bmp.bmWidth + 3) And -4& ' bmi to be re-used later (ARR2PIC) With bmi.bmiHeader .biSize = Len(bmi.bmiHeader) .biCompression = BI_RGB .biPlanes = 1 .biBitCount = bpp .biHeight = bmp.bmHeight .biWidth = bmp.bmWidth .biSizeImage = tmp * .biHeight ' If the picture's color format matches the ' requirement and no range is specified, ' fill savearray-structure If bmp.bmBits <> 0 _ And bmp.bmBitsPixel = bpp _ And flg = True Then With sar .cbElements = 1 .pvData = bmp.bmBits .cDims = dims If dims = 1 Then .Dim1UBound = bmi.bmiHeader.biSizeImage / fct .Dim2UBound = 0 Else .Dim1UBound = bmp.bmHeight .Dim2UBound = tmp / fct End If End With Erase arr API_CopyByRef ptr, ByVal VarPtr(arr) + var_pvData, dWord API_CopyByRef ByVal ptr, VarPtr(sar), dWord BMP2ARR = True Else ' otherwise, convert it via GetDIBits ' and copy its data to a bytearray If dims = 1 Then ReDim arr(.biSizeImage / fct - 1) arrINF arr, ptr Else ReDim arr(tmp / fct - 1, .biHeight - 1) arrINF arr, ptr End If sar = dmy hDC = API_GetDC(0) If hDC = 0 Then MsgBox "Gerätekontext konnte nicht erzeugt werden" ElseIf GDI_GetDIBits(hDC, hBM, 0, .biHeight, ptr, _ bmi, DIB_RGB_COLORS) = 0 Then MsgBox "Bilddaten konnten nicht gelesen werden" ElseIf flg Then BMP2ARR = True ElseIf bmpPart(bmi.bmiHeader, ptr, ptr, X1, XN, Y1, YN) Then BMP2ARR = True If dims = 1 Then ReDim Preserve arr(.biSizeImage / fct - 1) Else tmp = (bpp / 8# * .biWidth + 3) And -4& ptr = arrINF(arr) API_CopyByRef ByVal ptr + 16, .biHeight, 4 API_CopyByRef ByVal ptr + 24, CLng(tmp / fct), 4 End If End If If hDC Then API_ReleaseDC 0, hDC End If End With End If End Function ' BMP2PIC Convert bitmap to StandardPicture ' ' CALL: BMP2PIC(hBM, @tgt, [F1:tgtOwnsBmp], ' [F2:delBmpOnErr], [F3:srcMode]) ' ' IN: lng:hBM Bitmap handle ' obj:tgt StandardPicture object to be set ' bol:F1 .T.: tgt owns the handle (dflt) ' .F.: tgt does not own the handle ' bol:F2 .T.: delete hBM, if an err occurs (dflt) ' .F.: do not delete hBM on error ' enm:F3 hBM type (dflt=bitmap) ' ' OUT: bol success ' Function BMP2PIC( _ hBM As Long, _ tgt As StdPicture, _ Optional tgtOwnsBmp As Boolean = True, _ Optional delBmpOnErr As Boolean = False, _ Optional srcMode As PictureTypeConstants = vbPicTypeBitmap) As Boolean ' Neues Picture-Objekt Dim pic As IPicture ' info zum Erstellen eines neuen Pictures Dim dsc As PictDesc ' clsid des IPicture-Objektes Dim iid(15) As Byte dsc.cbSizeofStruct = Len(dsc) dsc.picType = srcMode dsc.hImage = hBM If OLE_CLSIDFromString(StrPtr(IID_IPicture), iid(0)) <> S_OK Then MsgBox "OLE Fehler" ElseIf OLE_CreatePic(dsc, iid(0), tgtOwnsBmp, pic) <> S_OK Then MsgBox "OLE picture creation error" Else Set tgt = Nothing Set tgt = pic BMP2PIC = True End If If (BMP2PIC = False) And delBmpOnErr Then GDI_DeleteObject hBM End Function Function bmpPart( _ bmh As BITMAPINFOHEADER, _ src As Long, _ tgt As Long, _ X1 As Long, _ XN As Long, _ Y1 As Long, _ YN As Long) As Boolean Static asm(35) As Long If asm(0) = 0 Then asm(0) = &HEC8B5590: asm(1) = &H8B575653: asm(2) = &H3B8B0C5D asm(3) = &H8B044B8B: asm(4) = &H538B0843: asm(5) = &H85D8B0C asm(6) = &HB0C738B: asm(7) = &H8B037FD2: asm(8) = &HC00B0853 asm(9) = &HAF0F607C: asm(10) = &H2BC203F0: asm(11) = &H4760843 asm(12) = &H5276D02B: asm(13) = &H37FC90B: asm(14) = &H8B044B8B asm(15) = &H7CC00BC7: asm(16) = &H7BB70F45: asm(17) = &H3EFC112 asm(18) = &HC7AF0F50: asm(19) = &H7303F003: asm(20) = &HC1035814 asm(21) = &H7604432B: asm(22) = &H76C82B04: asm(23) = &H1C4B8929 asm(24) = &HF205389: asm(25) = &HC183CFAF: asm(26) = &HFCE18003 asm(27) = &H8B244B89: asm(28) = &HC12B0C43: asm(29) = &HC12C7B8B asm(30) = &HF35102E9: asm(31) = &HF00359A5: asm(32) = &HF9F7754A asm(33) = &H1BF801EB: asm(34) = &H5B5E5FC0: asm(35) = &H10C25D End If ' ----------------------------------------------------------------- Dim abp As asmBmpPara Dim lng(3) As Long With abp.src .bmBits = src .bmBitsPixel = bmh.biBitCount .bmHeight = bmh.biHeight .bmWidth = bmh.biWidth .bmPlanes = bmh.biPlanes .bmWidthBytes = ((.bmBitsPixel \ 8) * .bmWidth + 3) And -4& End With abp.tgt = abp.src abp.tgt.bmBits = tgt lng(0) = X1 lng(1) = XN lng(2) = Y1 lng(3) = YN If ASM_cdByRef(asm(0), abp, lng(0), 0&, 0&) Then With abp.tgt bmh.biWidth = .bmWidth bmh.biHeight = .bmHeight bmh.biSizeImage = (((.bmBitsPixel \ 8) * .bmWidth + 3) _ And -4&) * .bmHeight bmpPart = True End With End If End Function '----------- Ende Modul "bmpROU" alias bmpROU.bas ----------- '------- Anfang Modul "bmpRotate" alias bmpRotate.bas ------- '--------------------------------------------------------------------------------------- ' Module : bmpRotate ' Author : (softKUS) - VII/2004 ' Purpose : rotates bitmaps with several options like antiA ' ' Hints - You may use this code in your programs at your own risk ' - You may not publish/sell it without the authour's agreement ' ' - If you have suggestions for improvements or corrections, ' please do not hesitate to email them to info@softkus.de '--------------------------------------------------------------------------------------- Option Explicit ' asmRotate Rotieren einer Bitmap ' ' AUFRUF: asmRotate(src, tgt, [Angle], [fctX], [fctY], ' [cut], [Adjust], [AntiA], [dfltAA], ' [useMsk], [mskCol], [AutoMsk], [FillMsk]) ' ' EIN: pic:src Standardpicture mit gültigem Bild ' pic:tgt Standardpicture ' dbl:Angle Winkel in 10tel Grad (Vorgabe = 90°) ' dbl:fctX Größenfaktor Breite (Vorgabe = 1 = 100%) ' dbl:fctY Größenfaktor Höhe (Vorgabe = 1 = 100 %) ' bol:cut Bild abschneiden (Vorgabe = False) ' bol:Adjust Bild an die neuen Dimensionen anpassen (Vorgabe = True) ' bol:AntiA Bild glätten (Vorgabe = True) ' dbl:dlftAA AntiA-Faktor, wenn Angle mod 90 = 0 (Vorgabe = 0) ' bol:UseMsk Eine Farbe maskieren (Vorgabe = False) ' lng:MskCol Vorgabe = 0 ' bol:AutoMsk 1. Bildpunkt = Maskierfarbe (Vorgabe = True) ' lng:FilMsk Fülle ungenutze Bereicht mit MskCol (Vorgabe = False) ' ' AUS: bol Erfolg ' Function asmRotate( _ src As StdPicture, _ tgt As StdPicture, _ Optional Angle As Double = 90, _ Optional fctX As Double = 1, _ Optional fctY As Double = 1, _ Optional cut As Boolean = False, _ Optional Adjust As Boolean = True, _ Optional AntiA As Boolean = True, _ Optional dfltAA As Double = 0, _ Optional UseMsk As Boolean = False, _ Optional MskCol As Long = 0, _ Optional AutoMsk As Boolean = True, _ Optional FillMsk As Boolean = False, _ Optional X1 As Long, _ Optional XN As Long = -1, _ Optional Y1 As Long, _ Optional YN As Long = -1) As Boolean Static asm(181) As Long If asm(0) = 0 Then asm(0) = &HEC8B5590: asm(1) = &H8B575653: asm(2) = &H738B085D asm(3) = &H2C7B8B14: asm(4) = &H3320538B: asm(5) = &H504850C0 asm(6) = &HF710458B: asm(7) = &H41445: asm(8) = &H1740000 asm(9) = &HC1C80FAD: asm(10) = &H575008E8: asm(11) = &H80144D8B asm(12) = &HE18312F1: asm(13) = &HC1F6511F: asm(14) = &H8B087408 asm(15) = &HAF0F1C4B: asm(16) = &H83ABF3CA: asm(17) = &HF48B5CEC asm(18) = &H507ED99B: asm(19) = &H80D4458B: asm(20) = &H89660CCC asm(21) = &H6ED95246: asm(22) = &HC458B52: asm(23) = &H40DDEED9 asm(24) = &H3840DD48: asm(25) = &H524040DD: asm(26) = &H5EDDC1D9 asm(27) = &H3056DD38: asm(28) = &H511C4B8B: asm(29) = &HC2D9E8D9 asm(30) = &HDA5856DB: asm(31) = &HE1D95866: asm(32) = &HDF9BD5D8 asm(33) = &H759E9BE0: asm(34) = &HDDC4D802: asm(35) = &H66DC205E asm(36) = &H285EDD20: asm(37) = &HC1D9E8D9: asm(38) = &HDA5456DB asm(39) = &HE1D95466: asm(40) = &HDF9BD5D8: asm(41) = &H759E9BE0 asm(42) = &HDDC4D802: asm(43) = &H66DC105E: asm(44) = &H185EDD10 asm(45) = &H3B584E8B: asm(46) = &H8D0F044B: asm(47) = &H14C asm(48) = &H3B547E8B: asm(49) = &H8D0F087B: asm(50) = &H140 asm(51) = &H11445F7: asm(52) = &HF000000: asm(53) = &HF284& asm(54) = &H99C03300: asm(55) = &HFCA3B4A: asm(56) = &H1278C asm(57) = &HFFA3B00: asm(58) = &H11F8C: asm(59) = &H78C90B00 asm(60) = &H41010C02: asm(61) = &H7D044B3B: asm(62) = &HB020C02 asm(63) = &HC0278FF: asm(64) = &H7B3B4704: asm(65) = &HC027D08 asm(66) = &HF4F4908: asm(67) = &H30C7BAF: asm(68) = &H3C8D147B asm(69) = &HE8538F: asm(70) = &H5B000000: asm(71) = &H134C381 asm(72) = &H5BD70000: asm(73) = &HA8E44D8B: asm(74) = &HE8077401 asm(75) = &H12F: asm(76) = &H118B0275: asm(77) = &HC7831689 asm(78) = &H7402A804: asm(79) = &H11DE807: asm(80) = &H2750000 asm(81) = &H5689118B: asm(82) = &HC7B0304: asm(83) = &H77408A8 asm(84) = &H10AE8: asm(85) = &H8B027500: asm(86) = &HC568911 asm(87) = &HA804EF83: asm(88) = &HE8077404: asm(89) = &HF7 asm(90) = &H118B0275: asm(91) = &HB9085689: asm(92) = &H2 asm(93) = &HE2C1D58A: asm(94) = &H8AC03308: asm(95) = &HDB503104 asm(96) = &H4EDC2404: asm(97) = &H184EDC28: asm(98) = &H31448A58 asm(99) = &H4DB5004: asm(100) = &H204EDC24: asm(101) = &HDE184EDC asm(102) = &H448A58C1: asm(103) = &HDB500831: asm(104) = &H4EDC2404 asm(105) = &H104EDC28: asm(106) = &H8A58C1DE: asm(107) = &H500C3144 asm(108) = &HDC2404DB: asm(109) = &H4EDC204E: asm(110) = &HDBC1DE10 asm(111) = &H8A58241C: asm(112) = &HB27949D0: asm(113) = &H9EE8& asm(114) = &HB17EB00: asm(115) = &HB3D78C9: asm(116) = &HF3978FF asm(117) = &H30C7BAF: asm(118) = &H3C8D147B: asm(119) = &H7DE88F asm(120) = &H28740000: asm(121) = &H89E47D8B: asm(122) = &H1445F717 asm(123) = &H10: asm(124) = &H4D831A74: asm(125) = &H438B20E0 asm(126) = &H24042B1C: asm(127) = &H73EC453B: asm(128) = &HEC458903 asm(129) = &H73F04539: asm(130) = &HF0458903: asm(131) = &H4E44583 asm(132) = &HDD0C458B: asm(133) = &HC2DE1840: asm(134) = &HDE3040DD asm(135) = &HF4959C1: asm(136) = &HFFFE4E85: asm(137) = &H545EDBFF asm(138) = &HF7585EDB: asm(139) = &H30E045: asm(140) = &H6750000 asm(141) = &H2924538B: asm(142) = &H4A5AE455: asm(143) = &H46DD3674 asm(144) = &H2860DC38: asm(145) = &HDC3046DD: asm(146) = &H18E92040 asm(147) = &HFFFFFE: asm(148) = &H0: asm(149) = &H30201 asm(150) = &HC0804: asm(151) = &H8B0F0A05: asm(152) = &H8E2C117 asm(153) = &HF708EAC1: asm(154) = &H2E045: asm(155) = &H3750000 asm(156) = &HC3E8553B: asm(157) = &HDD305EDD: asm(158) = &H6ED9385E asm(159) = &H1445F750: asm(160) = &H10: asm(161) = &H458B4274 asm(162) = &H2C432BE4: asm(163) = &H2473F799: asm(164) = &H2B204387 asm(165) = &H43292043: asm(166) = &HEC758B20: asm(167) = &H2BF0458B asm(168) = &H438740C6: asm(169) = &H1C432B1C: asm(170) = &HE0C11E74 asm(171) = &H24432902: asm(172) = &H8D2C7B8B: asm(173) = &H4B8BB734 asm(174) = &H2E9C124: asm(175) = &H5120538B: asm(176) = &H359A5F3 asm(177) = &HF7754AF0: asm(178) = &HF4658DF9: asm(179) = &H5E5FC01B asm(180) = &H10C25D5B: asm(181) = &H0 End If ' ************************************************************************** Dim sar As SAFEARRAY2D Dim bmi As BITMAPINFO Dim abp As asmBmpPara Dim dbl(10) As Double Dim flg As Long Dim src_buf() As Long Dim tgt_buf() As Long Const xPI As Double = 3.14159265358979 / 180 ' Einlesen der Bildinformationen If Angle < 0 Or Angle > 360 Then ElseIf BMP2ARR(src.Handle, src_buf, bmi, sar, 32, 1, X1, Y1, XN, YN) Then ' Setzen der abp-Struktur (source) With abp.src .bmBits = VarPtr(src_buf(0)) .bmBitsPixel = 32 .bmHeight = bmi.bmiHeader.biHeight .bmWidth = bmi.bmiHeader.biWidth .bmPlanes = 1 .bmWidthBytes = .bmWidth * 4 End With ' Setzen der abp-Struktur (target) abp.tgt = abp.src With abp.tgt .bmWidth = .bmWidth * fctX .bmHeight = .bmHeight * fctY If cut = False Or Adjust = True Then .bmWidth = .bmWidth * .bmWidth .bmHeight = .bmHeight * .bmHeight .bmWidth = Sqr(.bmWidth + .bmHeight) .bmHeight = .bmWidth End If ReDim tgt_buf(.bmWidth * .bmHeight - 1) .bmBits = VarPtr(tgt_buf(0)) .bmWidthBytes = .bmWidth * 4 ' Berechnen der Faktoren dbl(0) = Angle dbl(1) = Cos(Angle * xPI) dbl(2) = Sin(Angle * xPI) dbl(3) = dbl(1) / fctX dbl(4) = dbl(1) / fctY dbl(5) = dbl(2) / fctX dbl(6) = dbl(2) / fctY dbl(7) = (abp.src.bmWidth + (dbl(2) - dbl(1)) * .bmWidth / fctX) / 2 dbl(8) = (abp.src.bmHeight - (dbl(2) + dbl(1)) * .bmHeight / fctY) / 2 dbl(9) = dfltAA End With ' Aufruf der ASM-Funktion flg = (AntiA And 1) _ Or (UseMsk And 2) _ Or (AutoMsk And 4) _ Or (FillMsk And 8) _ Or (Adjust And 16) ASM_cdByRef asm(0), abp, dbl(0), ByVal MskCol, ByVal flg ' Erstellen/Zurückgeben eines neuen Bildes With bmi.bmiHeader .biHeight = abp.tgt.bmHeight .biWidth = abp.tgt.bmWidth .biSizeImage = .biWidth * .biHeight * 4 asmRotate = ARR2PIC(tgt_buf, bmi, tgt) End With ' Wenn die Original-Bilddaten verwendet wurden, ' (sar-pvData gesetzt), arr auf Nullpointer setzen If sar.pvData Then API_CopyByRef ByVal VB6_ArrayPointer(src_buf), 0&, dWord End If End If End Function ' basRotate Rotieren einer Bitmap ' ' AUFRUF: basRotate(src, tgt, [Angle], [fctX], [fctY], ' [cut], [Adjust], [AntiA], [dfltAA], ' [useMsk], [mskCol], [AutoMsk], [FillMsk]) ' ' EIN: pic:src Standardpicture mit gültigem Bild ' pic:tgt Standardpicture ' dbl:Angle Winkel in 10tel Grad (Vorgabe = 90°) ' dbl:fctX Größenfaktor Breite (Vorgabe = 1 = 100%) ' dbl:fctY Größenfaktor Höhe (Vorgabe = 1 = 100 %) ' bol:cut Bild abschneiden (Vorgabe = False) ' bol:Adjust Bild an die neuen Dimensionen anpassen ' (Vorgabe = True) ' bol:AntiA Bild glätten (Vorgabe = True) ' dbl:dlftAA AntiA-Faktor, wenn Angle mod 90 = 0 ' (Vorgabe = 0) ' bol:UseMsk Eine Farbe maskieren (Vorgabe = False) ' lng:MskCol Vorgabe = 0 ' bol:AutoMsk 1. Bildpunkt = Maskierfarbe ' (Vorgabe = True) ' lng:FilMsk Fülle ungenutze Bereicht mit MskCol ' (Vorgabe = False) ' ' AUS: bol Erfolg ' Function basRotate( _ src As StdPicture, _ tgt As StdPicture, _ Optional Angle As Double = 90, _ Optional fctX As Double = 1, _ Optional fctY As Double = 1, _ Optional cut As Boolean = False, _ Optional Adjust As Boolean = True, _ Optional AntiA As Boolean = True, _ Optional dfltAA As Double = 0, _ Optional UseMsk As Boolean = False, _ Optional MskCol As Long = 0, _ Optional AutoMsk As Boolean = True, _ Optional FillMsk As Boolean = False, _ Optional X1 As Long, _ Optional XN As Long = -1, _ Optional Y1 As Long, _ Optional YN As Long = -1) As Boolean Dim src_sar As SAFEARRAY2D Dim src_bmi As BITMAPINFO Dim tgt_bmi As BITMAPINFO Dim rmd(3) As Double Dim acos As Double Dim asin As Double Dim actX As Double Dim actY As Double Dim svdX As Double Dim svdY As Double Dim intX As Long Dim intY As Long Dim tmpX As Long Dim tmpY As Long Dim tmpC As Long Dim tgtW As Long Dim tgtH As Long Dim row As Long Dim col As Long Dim pnt As Long Dim vld As Long Dim I1 As Long Dim src_buf() As Byte Dim tgt_buf() As Byte Dim act(2, 3) As Byte Dim col1 As Long Dim row1 As Long Dim col2 As Long Dim row2 As Long Const xPI As Double = 3.14159265358979 / 180 If Angle < 0 Or Angle > 360 Then ElseIf BMP2ARR(src.Handle, src_buf, src_bmi, src_sar, 24, 2, X1, _ Y1, XN, YN) Then tgt_bmi = src_bmi ' Berechnen von Zielbreite und -höhe With src_bmi.bmiHeader tgtW = .biWidth * fctX tgtH = .biHeight * fctY If cut = False Or Adjust = True Then tgtW = Sqr(tgtW * tgtW + tgtH * tgtH) tgtH = tgtW End If With tgt_bmi.bmiHeader .biWidth = tgtW .biHeight = tgtH .biSizeImage = ((tgtW * 3 + 3) And -4&) * tgtH End With ' Zielarray dimensionieren ReDim tgt_buf(((tgtW * 3 + 3) And -4&) - 1, tgtH - 1) ' Faktoren berechnen acos = Cos(Angle * xPI) asin = Sin(Angle * xPI) actX = (.biWidth + (asin - acos) * tgtW / fctX) / 2 actY = (.biHeight - (asin + acos) * tgtH / fctY) / 2 col1 = &H7FFFFFFF row1 = col1 If AutoMsk Then API_CopyByRef MskCol, src_buf(0, 0), 3 MskCol = (MskCol And 255) * &H10000 + _ (MskCol And &HFF00&) + (MskCol \ &H10000) ' ggf. Bild mit Maskfarbe füllen If FillMsk Then For row = 0 To tgtH - 1 For col = 0 To tgtW - 1 API_CopyByRef tgt_buf(col * 3, row), MskCol, 3 Next Next End If ' row-loop For row = 0 To tgtH - 1 svdX = actX svdY = actY ' column-loop For col = 0 To tgtW - 1 intX = Fix(actX) intY = Fix(actY) ' Punkt validieren vld = ((intX >= 0 And intX < .biWidth) And 1) _ + ((intX > -2 And intX + 1 < .biWidth) And 2) _ + ((intY >= 0 And intY < .biHeight) And 4) _ + ((intY > -2 And intY + 1 < .biHeight) And 8) vld = Choose(vld + 1, 0, 0, 0, 0, 0, 1, 2, _ 3, 0, 4, 8, 12, 0, 5, 10, 15) If vld = 0 Then ' ungültiger Punkt ElseIf AntiA Then ' Farb-Mittelwerte berechnen tmpX = intX tmpY = intY tmpC = 0 pnt = 0 For I1 = 0 To 3 API_CopyByRef act(0, I1), tgt_buf(col * 3, row), 3 If (vld And 1) Then API_CopyByRef tmpC, src_buf(tmpX * 3, tmpY), 3 If UseMsk = False Or tmpC <> MskCol Then API_CopyByRef act(0, I1), tmpC, 3 End If End If tmpX = tmpX + 1 If I1 = 1 Then tmpX = tmpX - 2: tmpY = tmpY + 1 vld = Fix(vld / 2) Next rmd(1) = Abs(actX - intX) rmd(3) = Abs(actY - intY) If rmd(1) = 0 Then rmd(1) = dfltAA End If If rmd(3) = 0 Then rmd(3) = dfltAA rmd(0) = 1 - rmd(1) rmd(2) = 1 - rmd(3) For I1 = 2 To 0 Step -1 pnt = pnt * 256 _ + ((act(I1, 0) * rmd(0) * rmd(2) _ + act(I1, 1) * rmd(1) * rmd(2) _ + act(I1, 2) * rmd(0) * rmd(3) _ + act(I1, 3) * rmd(1) * rmd(3)) And 255) Next vld = 1 ElseIf (vld And 5) = 5 Then API_CopyByRef pnt, src_buf(intX * 3, intY), 3 End If ' Punkt übergehen If vld = 0 Then ElseIf pnt <> MskCol Or UseMsk = False Then ' Minima/Maxima festhalten If col1 > col Then col1 = col If row1 > row Then row1 = row If col2 < col Then col2 = col If row2 < row Then row2 = row ' Farbwert in Zielpuffer kopieren API_CopyByRef tgt_buf(col * 3, row), pnt, 3 End If actX = actX + acos / fctX actY = actY + asin / fctY Next actX = svdX - asin / fctX actY = svdY + acos / fctY Next End With ' ggf. Bild gemäß Minima/Maxima verschieben If Adjust = True Then With tgt_bmi.bmiHeader .biWidth = col2 - col1 + 1 .biHeight = row2 - row1 + 1 tgtW = (.biWidth * 3 + 3) And -4& .biSizeImage = tgtW * .biHeight End With If col1 > 0 Or row1 > 0 Then pnt = VarPtr(tgt_buf(0, 0)) For row = row1 To row2 API_CopyByRef ByVal pnt, tgt_buf(col1 * 3, row), tgtW pnt = pnt + tgtW Next End If End If ' neues Bitmap erstellen und auf tgt-Picture setzen basRotate = ARR2PIC(tgt_buf, tgt_bmi, tgt) If src_sar.pvData Then API_CopyByRef ByVal VB6_ArrayPointer(src_buf), 0&, dWord End If End If End Function '-------- Ende Modul "bmpRotate" alias bmpRotate.bas -------- '-------------- Ende Projektdatei Projekt1.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 2 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 Endres am 07.08.2008 um 21:45
Cool!
Sogar Stufenlos!
Kommentar von Stefan am 24.10.2005 um 18:07
Einfach klasse!
Ich habe schon mehrere derartige Routinen ausprobiert. Alles nicht so das Wahre. Dies funktioniert einfach super!
Sehr schnell oud fehlerfrei!