Startseite / Tipps / VB 5/6-Tipp 0618: Ein Bild mithilfe von ASM drehen

VB 5/6-Tipp 0618: Ein Bild mithilfe von ASM drehen

 von Daniel Aue

'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 -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "DestP"
' Steuerelement: Bildfeld-Steuerelement "SourceP"

'***********************************************************
'* Rotating 24Bit Bitmaps in 90° steps *very* fast via asm *
'* by Daniel Aue for activevb.de 5.8.2003                  *
'*                                                         *
'* USE ENTIRELY AT YOUR OWN RISK.                          *
'* you may publish this source as long as                  *
'* this commentblock stays in                              *
'***********************************************************
'rest of the comments are in german... it's just easier to express, sorry.

Option Explicit

Private Declare Function CreateDIBSection Lib "gdi32.dll" ( _
        ByVal hdc As Long, _
        pBitmapInfo As BITMAPINFO, _
        ByVal un As Long, _
        ByVal lplpVoid As Long, _
        ByVal handle As Long, _
        ByVal dw As Long) As Long

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject _
         As Long) As Long

Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" ( _
        ByVal hObject As Long, _
        ByVal nCount As Long, _
        lpObject As Any) As Long
        
Private Declare Function SetDIBits Lib "gdi32" ( _
         ByVal hdc As Long, ByVal hBitmap As Long, _
         ByVal nStartScan As Long, ByVal nNumScans As Long, _
         lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) _
         As Long
         
Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type

Private 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

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0

Private Const ASM_ROTATE90 = 0
Private Const ASM_ROTATE180 = 1
Private Const ASM_ROTATE270 = 2
Private Const ASM_ROTATESPECIAL = 3

Sub DoASMRotate(Angle)
    Dim SourceBMP As BITMAP
    Dim DestBMP As BITMAP
    
    'infos über das QuellBmp holen
    Call GetObject(SourceP.Picture, Len(SourceBMP), SourceBMP)
    
    If SourceBMP.bmBitsPixel <> 24 Then
        MsgBox "Geht nur mit 24bit Grafiken!"
        Exit Sub
    End If
    
    If (SourceBMP.bmWidthBytes And 3) <> 0 Then
        'is ja nicht zu fassen: GetObject liefert unter Windows 2000 bei Bitmaps
        'mit Padbytes tatsächlich eine falsche (nicht durch 4 teilbare) Breite !
        SourceBMP.bmWidthBytes = SourceBMP.bmWidthBytes + 2
    End If
    
    'DIB erstellen das Platz für die gedrehten Daten bietet:
    Dim DestBmpInfo As BITMAPINFO
    Dim PtrData As Long
    Dim hDib As Long
    
    With DestBmpInfo.bmiHeader
        .biSize = Len(DestBmpInfo.bmiHeader)
        
        If Angle = 90 Or Angle = 270 Then
        
            'Breite = Höhe des Quell BMP
            .biWidth = SourceBMP.bmHeight
            
            'Höhe = Breite des Quell BMP
            .biHeight = SourceBMP.bmWidth
            
        ElseIf Angle = 180 Then
        
            'Breite = Breite des Quell BMP
            .biWidth = SourceBMP.bmWidth
            
            'Höhe = Höhe des Quell BMP
            .biHeight = SourceBMP.bmHeight
            
        Else
            
            'Breite = Breite des Quell BMP
            .biWidth = SourceBMP.bmWidth
            
            'Höhe = Höhe des Quell BMP * 2
            .biHeight = SourceBMP.bmHeight * 2
            
        End If
            
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
    End With

    hDib = CreateDIBSection(0, DestBmpInfo, DIB_RGB_COLORS, VarPtr(PtrData), 0, 0)

    'infos über das gerade erstellte Bmp holen
    Call GetObject(hDib, Len(DestBMP), DestBMP)
    
    If (DestBMP.bmWidthBytes And 3) <> 0 Then
        'is ja nicht zu fassen: GetObject liefert unter Windows 2000 bei Bitmaps
        'mit Padbytes tatsächlich eine falsche (nicht durch 4 teilbare) Breite !
        DestBMP.bmWidthBytes = DestBMP.bmWidthBytes + 2
    End If
    
    'Parameterstruct für den asm aufruf initialisieren:
    Dim AsmPara(8) As Long
    
    'Zeiger auf Source Daten
    AsmPara(0) = SourceBMP.bmBits
    
    'Zeiger auf Ziel Daten
    AsmPara(1) = PtrData
    
    'Breite des Source Bitmaps
    AsmPara(2) = SourceBMP.bmWidth
    
    'Höhe des Source Bitmaps
    AsmPara(3) = SourceBMP.bmHeight
    
    'Bytes pro Zeile des Source Bitmaps
    AsmPara(4) = SourceBMP.bmWidthBytes
    
    'Bytes pro Zeile des Dest Bitmaps
    AsmPara(5) = DestBMP.bmWidthBytes
    
    'Grad um die gedreht werden soll
    Select Case Angle
        Case 90
            AsmPara(6) = ASM_ROTATE90
            
            'hier könnte der dest offset per pixel angegeben werden
            AsmPara(7) = 0
            
            'hier könnte der dest offset per line angegeben werden
            AsmPara(8) = 0
        Case 180
            AsmPara(6) = ASM_ROTATE180
            
            'hier könnte der dest offset per pixel angegeben werden
            AsmPara(7) = 0
            
            'hier könnte der dest offset per line angegeben werden
            AsmPara(8) = 0
        Case 270
            AsmPara(6) = ASM_ROTATE270
            
            'hier könnte der dest offset per pixel angegeben werden
            AsmPara(7) = 0
            
            'hier könnte der dest offset per line angegeben werden
            AsmPara(8) = 0
        Case Else
            AsmPara(6) = ASM_ROTATESPECIAL
            'wird im Parameter 6 ASM_ROTATESPECIAL angegeben können mit
            'den beiden folgenden Parametern die Offsets angegeben werden
            'die einerseits nach jedem _Pixel_ zu der Zieladresse addiert
            'werden sollen (Nach dem Kopieren eines Pixels steht die
            'Ziel-Adresse automatisch am nächsten Pixel links davon),
            'anderseits der Offset der nach jeder _Zeile_ zu der Zieladresse
            'dazuaddiert werden sollen (Nach einer Zeile steht die Ziel-
            'adresse wieder am Anfang dieser Zeile).
            'Achtung: auch die Zieladresse selber muss dann natürlich auch
            'anders initialisiert werden (nicht auf das erste Byte im
            'Zielarray)

            'einen Pixel weiter links (minus 6 Bytes)
            AsmPara(7) = -6
            
            'zwei Zeilen springen
            AsmPara(8) = -DestBMP.bmWidthBytes * 2
            
            'Startadresse korrigieren
            AsmPara(1) = PtrData + DestBMP.bmWidthBytes * DestBMP.bmHeight - _
                        (DestBMP.bmWidthBytes - DestBMP.bmWidth * 3) - 3
    End Select
    
    
    'ASM code initialisieren:
    Dim asm(51) As Long
    
    'check asm.txt for the source
    asm(0) = &H90EC8B55:  asm(1) = &H8B535657
    asm(2) = &H428B0855:  asm(3) = &HF88318
    asm(4) = &HF8831C74:  asm(5) = &H83367401
    asm(6) = &H5C7402F8:  asm(7) = &H7403F883
    asm(8) = &H5F5E5B72:  asm(9) = &HFFFFB85D
    asm(10) = &HC290FFFF: asm(11) = &H7A8B0010
    asm(12) = &H8428B04:  asm(13) = &H42AF0F48
    asm(14) = &HBBF80314: asm(15) = &H3&
    asm(16) = &HB8&:      asm(17) = &H14422B00
    asm(18) = &HEB03E883: asm(19) = &H47A8B4F
    asm(20) = &HF0C428B:  asm(21) = &H31442AF
    asm(22) = &H85A8BF8:  asm(23) = &H8B5B0C8D
    asm(24) = &HD92B145A: asm(25) = &HEF83FB2B
    asm(26) = &HBB03&:    asm(27) = &H5A2B0000
    asm(28) = &HFFFAB814: asm(29) = &H24EBFFFF
    asm(30) = &H8B047A8B: asm(31) = &H48D0C5A
    asm(32) = &H83F8035B: asm(33) = &HFDBB03EF
    asm(34) = &H8BFFFFFF: asm(35) = &HE8831442
    asm(36) = &H8B09EB03: asm(37) = &H5A8B047A
    asm(38) = &H1C428B20: asm(39) = &H51104A8B
    asm(40) = &H51084A8B: asm(41) = &H528B328B
    asm(42) = &H240C8B0C: asm(43) = &HA4A45756
    asm(44) = &HE2F803A4: asm(45) = &H35E5FF9
    asm(46) = &H247403FB: asm(47) = &HE9754A04
    asm(48) = &H5E5B5858: asm(49) = &HB85D5F
    asm(50) = &H90000000: asm(51) = &H10C2&

    'drehen:
    'Achtung: Die Funktion prüft nicht auf Speichergrenzen etc.
    'wurde ein Parameter falsch initialisiert, oder beim reservieren
    'des Zielspeichers ein Fehler gemacht, so kommts jetzt unweigerlich
    'zu einem Absturz !
    Dim Result As Long
    Result = CallWindowProc(VarPtr(asm(0)), VarPtr(AsmPara(0)), 0, 0, 0)
    
    If Result <> 0 Then
        MsgBox "Fehler in den ASM Parametern!"
    End If
    
    Dim bw As Integer
    DestP.AutoRedraw = True ' wichtig
    DestP.ScaleMode = 3
    Me.ScaleMode = 3
    bw = DestP.Width - DestP.ScaleWidth
    DestP.Width = DestBmpInfo.bmiHeader.biWidth + bw
    DestP.Height = DestBmpInfo.bmiHeader.biHeight + bw
                
    DestP.Cls
    'in der picturebox anzeigen:
    Result = SetDIBits(DestP.hdc, DestP.Image.handle, 0, _
        DestBmpInfo.bmiHeader.biHeight, ByVal PtrData, DestBmpInfo, DIB_RGB_COLORS)
    DestP.Refresh
    
    DeleteObject (hDib)
End Sub

Private Sub Command1_Click()
    DoASMRotate Combo1.Text
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 7 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.