Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0724: Blueboxing

VB 5/6-Tipp 0724: Blueboxing

 von Danielo

Schwierigkeitsgrad:

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

Download: Download des Beispielprojektes [35 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 -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "cmdBenchmark"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Vertikale Scrollbar "scrColRange" (Index von 0 bis 5) auf Frame1
' Steuerelement: Beschriftungsfeld "lblValues" auf Frame1
' Steuerelement: Beschriftungsfeld "Label10" auf Frame1
' Steuerelement: Beschriftungsfeld "Label9" auf Frame1
' Steuerelement: Beschriftungsfeld "Label8" auf Frame1
' Steuerelement: Beschriftungsfeld "Label7" auf Frame1
' Steuerelement: Beschriftungsfeld "Label6" auf Frame1
' Steuerelement: Beschriftungsfeld "Label5" auf Frame1
' Steuerelement: Bildfeld-Steuerelement "picMask"
' Steuerelement: Bildfeld-Steuerelement "picResult"
' Steuerelement: Bildfeld-Steuerelement "picSource"
' Steuerelement: Bildfeld-Steuerelement "picDest"
' Steuerelement: Beschriftungsfeld "Label11"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Private Sub cmdBenchmark_Click()
   Dim udtColRange As BlueBoxColor
   Dim Ticks As Long
   Dim fps As Long
   Dim X As Integer
   Const ITERATIONS = 100
   
   Me.MousePointer = vbHourglass
   udtColRange.RedLow = 0
   udtColRange.RedHigh = 255
   udtColRange.GreenLow = 0
   udtColRange.GreenHigh = 255
   udtColRange.BlueLow = 0
   udtColRange.BlueHigh = 255
   
   Ticks = GetTickCount
   For X = 0 To ITERATIONS
    Set Me.picResult = DoASMBlueBox(Me.picSource, Me.picDest, Me.picMask, udtColRange)
   Next
   Ticks = GetTickCount - Ticks
   Me.MousePointer = vbDefault
   fps = 1000 / (Ticks / ITERATIONS)
   MsgBox fps & " Frames per Second"
End Sub

Private Sub Form_Load()
    Me.scrColRange(0) = 55
    Me.scrColRange(1) = 142
    Me.scrColRange(2) = 62
    Me.scrColRange(3) = 140
    Me.scrColRange(4) = 121
    Me.scrColRange(5) = 255
End Sub

Private Sub scrColRange_Change(Index As Integer)
    Update
End Sub

Private Sub scrColRange_Scroll(Index As Integer)
    Update
End Sub

Private Sub Update()
    Dim sOutText As String
    Dim udtColRange As BlueBoxColor
    
    'Ausgabetext unterhalb der Scroller aktualisieren:
    sOutText = Space(30)
    Mid(sOutText, 1) = Me.scrColRange(0) & "-" & Me.scrColRange(1)
    Mid(sOutText, 10) = Me.scrColRange(2) & "-" & Me.scrColRange(3)
    Mid(sOutText, 19) = Me.scrColRange(4) & "-" & Me.scrColRange(5)
    Me.lblValues = sOutText
    
    'Farbbereichs UDT für den ASM Call initialisieren, wobei
    'der niederige Wert jedes Scroller Paars ermittelt werden muss, um
    'zu wissen welcher High und welcher Low ist
    With udtColRange
        If Me.scrColRange(0) < Me.scrColRange(1) Then
            .RedLow = Me.scrColRange(0)
            .RedHigh = Me.scrColRange(1)
        Else
            .RedLow = Me.scrColRange(1)
            .RedHigh = Me.scrColRange(0)
        End If
        If Me.scrColRange(2) < Me.scrColRange(3) Then
            .GreenLow = Me.scrColRange(2)
            .GreenHigh = Me.scrColRange(3)
        Else
            .GreenLow = Me.scrColRange(3)
            .GreenHigh = Me.scrColRange(2)
        End If
        If Me.scrColRange(4) < Me.scrColRange(5) Then
            .BlueLow = Me.scrColRange(4)
            .BlueHigh = Me.scrColRange(5)
        Else
            .BlueLow = Me.scrColRange(5)
            .BlueHigh = Me.scrColRange(4)
        End If
    End With
    
    Set Me.picResult = DoASMBlueBox(Me.picSource, Me.picDest, Me.picMask, udtColRange)
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------- Anfang Modul "modBlueBox" alias BlueBox.bas  -------
Option Explicit

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 DeleteObject Lib "gdi32.dll" (ByVal hObject 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 Sub RtlMoveMemory Lib "kernel32.dll" _
        (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 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 Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
        (PicDesc As PICTDESC, RefIID As GUID, _
        ByVal fPictureOwnsHandle As Long, IPic As IPicture) 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 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

Public Type BlueBoxColor
  BlueLow As Byte
  BlueHigh As Byte
  GreenLow As Byte
  GreenHigh As Byte
  RedLow As Byte
  RedHigh As Byte
End Type


Public Function DoASMBlueBox(Source As StdPicture, Destination As StdPicture, _
            Mask As StdPicture, ColRange As BlueBoxColor) As StdPicture
'************************************************************************
'*                        Fast BlueBox Effects via ASM                  *
'*                           by Daniel Aue 01.2005                      *
'*                                                                      *
'*                     USE ENTIRELY AT YOUR OWN RISK.                   *
'*                 you may publish this source as long as               *
'*                      this commentblock stays in                      *
'************************************************************************
    Dim hdibsource As Long, hDibDest As Long, hDibMask As Long
    Dim lpDataSource As Long, lpDataDest As Long, lpDataMask As Long
    Dim udtBmpInfoSource As BITMAPINFO, udtBmpInfoDest As BITMAPINFO, udtBmpInfoMask As BITMAPINFO
    
    Dim nResult As Long
    
    lpDataSource = GetBitmapData(Source, 24, hdibsource, udtBmpInfoSource, False)
    lpDataDest = GetBitmapData(Destination, 24, hDibDest, udtBmpInfoDest)
    If Destination Is Mask Then
        'wenn Maske und Destination ident sind, kann ein und der selbe Zeiger als
        '    Maske und Dest der ASM Funktion übergeben werden.
        lpDataMask = lpDataDest
        udtBmpInfoMask = udtBmpInfoDest
    Else
        lpDataMask = GetBitmapData(Mask, 24, hDibMask, udtBmpInfoMask, False)
    End If
    
    'some checks:
    If Not (udtBmpInfoSource.bmiHeader.biSizeImage = udtBmpInfoDest.bmiHeader.biSizeImage And _
           udtBmpInfoDest.bmiHeader.biSizeImage = udtBmpInfoMask.bmiHeader.biSizeImage) Then
       Err.Raise 513, , "DoASMBlueBox: Alle 3 Bilder müssen gleich gross sein!"
    End If
       
       
    'initialize the Parameter Struct for the Asm Call:
    Dim AsmPara(13) As Long
    AsmPara(0) = lpDataSource
    AsmPara(1) = lpDataDest
    AsmPara(2) = lpDataMask
    AsmPara(3) = VarPtr(ColRange)
    With udtBmpInfoDest.bmiHeader
        AsmPara(4) = .biHeight
        AsmPara(5) = .biWidth
        AsmPara(6) = (.biSizeImage - (.biHeight * .biWidth * 3)) / .biHeight 'Anzahl der PadBytes
    End With

    Static asm(28) As Long

    If asm(0) = 0 Then
        asm(0) = &H57EC8B55:  asm(1) = &H6D8B5356:  asm(2) = &H8BFF3308:  asm(3) = &H5D8B0875
        asm(4) = &HC558B00:   asm(5) = &H8A144D8B:  asm(6) = &H23A3704:   asm(7) = &H423A3D72
        asm(8) = &H8A387701:  asm(9) = &H3A013744:  asm(10) = &H2F720242: asm(11) = &H7703423A
        asm(12) = &H37448A2A: asm(13) = &H4423A02:  asm(14) = &H423A2172: asm(15) = &H8B1C7705
        asm(16) = &H48A0455:  asm(17) = &H1704881F: asm(18) = &H11F448A:  asm(19) = &H1174488
        asm(20) = &H21F448A:  asm(21) = &H2174488:  asm(22) = &H830C558B: asm(23) = &H774903C7
        asm(24) = &H187D03B6: asm(25) = &H77104DFF: asm(26) = &H5F5E5BAB: asm(27) = &HC2C0335D
        asm(28) = &H10
    End If
      
  
    'call Asm Function
    nResult = CallWindowProc(VarPtr(asm(0)), VarPtr(AsmPara(0)), 0, 0, 0)
         
    DeleteObject (hdibsource)
    DeleteObject (hDibMask)
    Set DoASMBlueBox = DibToPicture(hDibDest)
End Function


Private Function GetBitmapData(SomePicture As StdPicture, Bpp As Byte, hDib As Long, _
        BmpInfoStruct As BITMAPINFO, Optional ForceCopy As Boolean = True) As Long
    'Get a Pointer to the RGB Data of a StdPicture
    'If the original Data is available in the required Color depth (Bpp Parameter),
    'and ForceCopy=false, the Pointer to the original Picture Data is returned,
    'otherwise a DIB is created, the Data is copied/transformed into the DIB and
    'the Handle is returned in hDip. In that case the calling Function is responsible
    'to delete the DIB Object
   
    'IN: SomePicture
    'IN: Bpp: required Color depth (16,24 oder 32)
    'IN: ForceCopy
    'OUT: hDib: Handle to a created DIB (if one was created)
    'OUT: BmpInfoStruct of the created DIB
    'RETURNS: Pointer to the RGB Data
    '
    'If ForceCopy=false and the original Data is available in the correct Color depth,
    '0 is returned in hDib
    Dim udtBmpStruct As BITMAP
    Dim lpData As Long
    Dim hDesktopDC As Long
    Dim Result As Long

    If Not (Bpp = 16 Or Bpp = 24 Or Bpp = 32) Then
        Err.Raise 513, , "ungültige Farbtiefe!"
    End If

    'get Infos
    If GetObject(SomePicture, Len(udtBmpStruct), udtBmpStruct) = 0 Then
        Err.Raise 513, , "GetBitmapData: GetObject Kann auf Bilddaten nicht zugreifen !"
        Exit Function 'We could'nt access the Data at all
    ElseIf (udtBmpStruct.bmWidthBytes And 3) <> 0 Then
        'Win2k oddity: PadBytes are calculated wrong !
        udtBmpStruct.bmWidthBytes = udtBmpStruct.bmWidthBytes + 2
    End If
  
    'init BitmapInfoHeader
    With BmpInfoStruct.bmiHeader
        .biSize = Len(BmpInfoStruct.bmiHeader)
        .biWidth = udtBmpStruct.bmWidth
        .biHeight = udtBmpStruct.bmHeight
        .biPlanes = 1
        .biBitCount = Bpp
        .biCompression = BI_RGB
        .biSizeImage = ((.biWidth * Bpp / 8 + 3) And &HFFFFFFFC) * .biHeight
    End With
  
  
    If udtBmpStruct.bmBits = 0 Or udtBmpStruct.bmBitsPixel <> Bpp Or ForceCopy = True Then
        'Create DIB:
        hDib = CreateDIBSection(0, BmpInfoStruct, DIB_RGB_COLORS, VarPtr(lpData), 0, 0)
        If hDib = 0 Then
           Err.Raise 513, , "GetBitmapData: Konnte DIB nicht erstellen !"
           Exit Function
        End If
        
        'Is the Format of the Source ok, or do we need some Translation ?
        If udtBmpStruct.bmBits <> 0 And udtBmpStruct.bmBitsPixel = Bpp Then
            'We can access the original Data and the Format fits.
            RtlMoveMemory lpData, udtBmpStruct.bmBits, BmpInfoStruct.bmiHeader.biSizeImage
        Else
            'Translation takes a bit longer.
            hDesktopDC = GetDC(0)
            Result = GetDIBits(hDesktopDC, SomePicture.handle, 0, udtBmpStruct.bmHeight, _
                ByVal lpData, BmpInfoStruct, DIB_RGB_COLORS)
            If Result = 0 Then
               Err.Raise 513, , "GetBitmapData: GetDIBits kann auf Bilddaten nicht zugreifen !"
            ElseIf ReleaseDC(0, hDesktopDC) = 0 Then
               Err.Raise 513, , "GetBitmapData: ReleaseDC ist fehlgeschlagen !"
            End If
        End If
        GetBitmapData = lpData
    Else
        GetBitmapData = udtBmpStruct.bmBits
        hDib = 0
    End If
 
End Function


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
   Call OleCreatePictureIndirect(vPic, vIDispatch, 1, DibToPicture) ' Convert image to OLE picture
End Function

'-------- Ende Modul "modBlueBox" alias BlueBox.bas  --------
'-------------- Ende Projektdatei Projekt1.vbp --------------