Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0653: Bitmaps drehen per ASM

 von 

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:

Schwierigkeitsgrad 3

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:

Download des Beispielprojektes [16,94 KB]

'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-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

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!