Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0642: Grafik schattieren per ASM

VB 5/6-Tipp 0642: Grafik schattieren per ASM

 von Daniel Aue

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), CreateDIBSection, GetDC, GetDIBits, GetDesktopWindow, GetObjectA (GetObject), OleCreatePictureIndirect, ReleaseDC

Download: Download des Beispielprojektes [62,54 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 AsmShade.vbp -------------
'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Vertikale Scrollbar "scrSizeY"
' Steuerelement: Horizontale Scrollbar "hsbSizeX"
' Steuerelement: Horizontale Scrollbar "hsbShade"
' Steuerelement: Bildfeld-Steuerelement "picSource"
' Steuerelement: Bildfeld-Steuerelement "picDest"


' ************************************************************************
' *                 Shading of Bitmaps *very* fast via asm               *
' *                 by Daniel Aue for activevb.de 14.8.2003              *
' *                                                                      *
' *                     USE ENTIRELY AT YOUR OWN RISK.                   *
' *                 you may publish this source as long as               *
' *                      this commentblock stays in                      *
' ************************************************************************
' V1.1: 14.8.2003 some Bugfixes (ReleaseDC, xor al,al added)
' V1.0: 12.8.2003 initial release

Option Explicit

Private Sub Form_Load()
    picDest.Picture = picSource.Picture
    Call Shade
End Sub

Private Sub Shade()
    Dim ShadeWidth As Integer
    Dim ShadeHeight As Integer
    Dim StartX As Integer
    Dim StartY As Integer
  
    ShadeWidth = hsbSizeX / 100 * picDest.ScaleWidth
    ShadeHeight = scrSizeY / 100 * picDest.ScaleHeight
    StartX = picDest.ScaleWidth / 2 - ShadeWidth / 2
    StartY = picDest.ScaleHeight / 2 - ShadeHeight / 2
  
    ' Notiz:
    ' Wenn die .Picture Eigenschaft 0 ist, wird die .Image
    ' Eigenschaft als Quelle verwendet
    picDest.Picture = DoASMShade(picSource.Picture, StartX, StartY, _
        ShadeWidth, ShadeHeight, hsbShade.Value)
End Sub

Private Sub hsbShade_Scroll()
    Call Shade
End Sub

Private Sub hsbShade_Change()
    Call Shade
End Sub

Private Sub hsbSizeX_Change()
    Call Shade
End Sub

Private Sub hsbSizeX_Scroll()
    Call Shade
End Sub

Private Sub scrSizeY_Change()
    Call Shade
End Sub

Private Sub scrSizeY_Scroll()
    Call Shade
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------- Anfang Modul "asm_Shade" alias asm_Shade.bas -------


' ************************************************************************
' *                 Shading of Bitmaps *very* fast via asm               *
' *                 by Daniel Aue for activevb.de 14.8.2003              *
' *                     USE ENTIRELY AT YOUR OWN RISK.                   *
' *                 you may publish this source as long as               *
' *                      this commentblock stays in                      *
' ************************************************************************
' V1.1: 14.8.2003 some Bugfixes
' V1.0: 12.8.2003 initial release

Option Explicit

Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" ( _
        ByVal hObject As Long, ByVal nCount As Long, ByVal lpObject 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
     
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        ByVal hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)
    
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 GetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, _
        ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, _
        lpBits As Long, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
        PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
        IPic As IPicture) As Long

Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long

Private Declare Function GetDC Lib "user32.dll" _
        (ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, _
        ByVal hdc 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 Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PICTDESC
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type


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


Private Function DibToPicture(HandleDIB) As StdPicture
    Dim vIDispatch As GUID
    Dim vPic As PICTDESC
   
    With vIDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    With vPic
        .cbSizeofStruct = Len(vPic)
        .picType = vbPicTypeBitmap
        .hImage = HandleDIB
    End With
    
    ' Das Bild in ein OLEpicture konvertieren
    Call OleCreatePictureIndirect(vPic, vIDispatch, 1, DibToPicture)
End Function


Public Function DoASMShade(SourcePicture As StdPicture, _
    ByVal XStart As Integer, ByVal YStart As Integer, _
    ByVal ShadeWidth As Integer, ByVal ShadeHeight As Integer, _
    ByVal ShadeValue As Byte) _
    As StdPicture

    Dim SourceBmp As BITMAP
    Dim DestBmpInfo As BITMAPINFO
    Dim hDib As Long
    Dim PtrData As Long
    Dim DibByteWith As Long
    Dim Result As Long
    
    Const ErrorNumberToUse = 513
  
    ' ********************
    ' Das Quellbitmap in ein neues DIB bekommen
   
    ' Informationen über die Quelle lesen
    If GetObject(SourcePicture, Len(SourceBmp), VarPtr(SourceBmp)) = 0 Then
        Err.Raise ErrorNumberToUse, "DOASMShade", _
            "DOASMShade: GetObject Kann auf Bilddaten nicht zugreifen!"
        
        Exit Function ' Wir konnten nicht auf die Quelle zugreifen
      
    ElseIf (SourceBmp.bmWidthBytes And 3) <> 0 Then
        
        ' Win2k Eigenheit: PadBytes werden falsch berechnet!
        SourceBmp.bmWidthBytes = SourceBmp.bmWidthBytes + 2
    End If
    
    ' BitmapInfoHeader mit Breite und Höhe der Quelle initialisieren usw.
    With DestBmpInfo.bmiHeader
        .biSize = Len(DestBmpInfo.bmiHeader)
        .biWidth = SourceBmp.bmWidth
        .biHeight = SourceBmp.bmHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
    End With
  
    ' Ist das Format ok oder brauchen wir eine Übersetzung?
    If SourceBmp.bmBits <> 0 And SourceBmp.bmBitsPixel = 24 Then
        DibByteWith = SourceBmp.bmWidthBytes
        DestBmpInfo.bmiHeader.biSizeImage = DibByteWith * _
            DestBmpInfo.bmiHeader.biHeight
    
        ' Wir können auf die Orginaldaten zugreifen und das Format passt
        hDib = CreateDIBSection(0, DestBmpInfo, DIB_RGB_COLORS, VarPtr(PtrData), 0, 0)
        If hDib = 0 Then
        
            Err.Raise ErrorNumberToUse, "DOASMShade", _
                "DOASMShade: Konnte DIB nicht erstellen!"
                
            Exit Function
        End If
    
        Call CopyMemory(ByVal PtrData, ByVal SourceBmp.bmBits, _
            DestBmpInfo.bmiHeader.biSizeImage)
  
    Else
        ' Das übersetzen braucht etwas länger.
        ' Von 16 und 32bpp zu 24bpp arbeitet es gut, aber es scheint, es
        ' gibt ein Problem mit der 256-Farben Palette.
    
        DibByteWith = (DestBmpInfo.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
        
        DestBmpInfo.bmiHeader.biSizeImage = DibByteWith * _
            DestBmpInfo.bmiHeader.biHeight
    
        hDib = CreateDIBSection(0, DestBmpInfo, DIB_RGB_COLORS, VarPtr(PtrData), 0, 0)
        If hDib = 0 Then
            Err.Raise ErrorNumberToUse, "DOASMShade", _
                "DOASMShade: Konnte DIB nicht erstellen!"
                
            Exit Function
        End If
    
        Dim hDesktopDC As Long
        hDesktopDC = GetDC(GetDesktopWindow())
        
        Result = GetDIBits(hDesktopDC, SourcePicture, 0, SourceBmp.bmHeight, _
            ByVal PtrData, DestBmpInfo, DIB_RGB_COLORS)
            
        If Result = 0 Then
            Err.Raise ErrorNumberToUse, "DOASMShade", _
                "DOASMShade: GetDIBits kann auf Bilddaten nicht zugreifen!"
                
        ElseIf ReleaseDC(0, hDesktopDC) = 0 Then
            Err.Raise ErrorNumberToUse, "DOASMShade", _
                "DOASMShade: ReleaseDC ist fehlgeschlagen!"
        End If
    
    End If
  
    ' Jetzt haben wir das Quellbitmap in ein 24bpp DIB umgewandelt
    ' ********************
    
    ' X, Y, ShadeWidth and ShadeHeigth PArameter prüfen und korrigieren
    If XStart < 0 Then XStart = 0
    
    If XStart > DestBmpInfo.bmiHeader.biWidth Then _
        XStart = DestBmpInfo.bmiHeader.biWidth
    
    If YStart < 0 Then YStart = 0
    
    If YStart > DestBmpInfo.bmiHeader.biHeight Then _
        YStart = DestBmpInfo.bmiHeader.biHeight
    
    If ShadeWidth + XStart > DestBmpInfo.bmiHeader.biWidth Then _
        ShadeWidth = DestBmpInfo.bmiHeader.biWidth - XStart
        
    If ShadeHeight + YStart > DestBmpInfo.bmiHeader.biHeight Then _
        ShadeHeight = DestBmpInfo.bmiHeader.biHeight - YStart
    
    ' Den Parameterstack für dem ASM initialisiere
    Dim AsmPara(8) As Long
    AsmPara(0) = PtrData              ' Pointer auf das zu manipulierende Bitmap
    AsmPara(1) = SourceBmp.bmWidth    ' Breite des Bitmaps
    AsmPara(2) = SourceBmp.bmHeight   ' Höhe des Bitmaps
    AsmPara(3) = DibByteWith          ' Bytes pro Scanline
    AsmPara(4) = XStart
    AsmPara(5) = YStart
    AsmPara(6) = ShadeWidth
    AsmPara(7) = ShadeHeight
    AsmPara(8) = ShadeValue
 
    Static asm(44) As Long
    
    ' Die Assemblerfunktion initialisieren
    If asm(0) = 0 Then
        asm(0) = &H57EC8B55:  asm(1) = &H6D8B5356
        asm(2) = &H87D8B08:   asm(3) = &H2B1C7D2B
        asm(4) = &HAF0F147D:  asm(5) = &H5D8B0C7D
        asm(6) = &H5B048D10:  asm(7) = &H7D03F803
        asm(8) = &H185D8B00:  asm(9) = &H7D74DB0B
        asm(10) = &H8B5B148D: asm(11) = &HDB0B1C5D
        asm(12) = &H458B7374: asm(13) = &H64F88320
        asm(14) = &H72F56B74: asm(15) = &HB1E88A68
        asm(16) = &HAF1F619:  asm(17) = &H344575E4
        asm(18) = &H7B267403: asm(19) = &H8BC03210
        asm(20) = &HAAF357CA: asm(21) = &HC7D035F
        asm(22) = &HEBF4754B: asm(23) = &H52C88A48
        asm(24) = &H472FD257: asm(25) = &H5FFA754A
        asm(26) = &HC7D035A:  asm(27) = &HEBF0754B
        asm(28) = &H8B575234: asm(29) = &HE8D0ACF7
        asm(30) = &HE8D0E08A: asm(31) = &H4AAAC402
        asm(32) = &H5A5FF375: asm(33) = &H4B0C7D03
        asm(34) = &H19EBE775: asm(35) = &H525764B1
        asm(36) = &HF6ACF78B: asm(37) = &HAAF1F6E5
        asm(38) = &H5AF7754A: asm(39) = &HC7D035F
        asm(40) = &HEBEB754B: asm(41) = &H5F5E5B00
        asm(42) = &HC2C01B5D: asm(43) = &H10&
        asm(44) = &HDA000000
    End If
    
    ' Die AsmShade Funktion aufrufen
    Result = CallWindowProc(VarPtr(asm(0)), VarPtr(AsmPara(0)), 0, 0, 0)
    If Result <> 0 Then
        Err.Raise ErrorNumberToUse, "DOASMShade", _
            "DOASMShade: Fehler in ASM Parameter!"
        
        Exit Function
    End If
    
    ' Ein StdPicture aus dem DIB erstellen
    Set DoASMShade = DibToPicture(hDib)
End Function
'-------- Ende Modul "asm_Shade" alias asm_Shade.bas --------
'-------------- Ende Projektdatei AsmShade.vbp --------------