Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/vbpg32/samples5/ch09/dibsect.frm

Visual Basic Form | 1997-02-16 | 8.4 KB | 234 lines

VERSION 5.00
Begin VB.Form frmDIBSection
   Caption         =   "DIBSection Demo"
   ClientHeight    =   4515
   ClientLeft      =   1095
   ClientTop       =   1515
   ClientWidth     =   5580
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4515
   ScaleWidth      =   5580
   Begin VB.CommandButton cmdWhiteRect
      Caption         =   "Draw Rect"
      Height          =   435
      Left            =   1980
      TabIndex        =   6
      Top             =   2880
      Width           =   1335
   End
   Begin VB.CommandButton cmdStrip
      Caption         =   "Strip Blue"
      Height          =   495
      Index           =   2
      Left            =   480
      TabIndex        =   5
      Top             =   2820
      Width           =   1035
   End
   Begin VB.CommandButton cmdStrip
      Caption         =   "Strip Green"
      Height          =   495
      Index           =   1
      Left            =   480
      TabIndex        =   4
      Top             =   2220
      Width           =   1035
   End
   Begin VB.CommandButton cmdStrip
      Caption         =   "Strip Red"
      Height          =   495
      Index           =   0
      Left            =   480
      TabIndex        =   3
      Top             =   1620
      Width           =   1035
   End
   Begin VB.CommandButton cmdRandom
      Caption         =   "Randomize"
      Height          =   495
      Left            =   480
      TabIndex        =   2
      Top             =   900
      Width           =   1035
   End
   Begin VB.CommandButton cmdUpdate
      Caption         =   "Update"
      Height          =   495
      Left            =   480
      TabIndex        =   1
      Top             =   240
      Width           =   1035
   End
   Begin VB.PictureBox picDisplay
      Height          =   2355
      Left            =   1980
      ScaleHeight     =   155
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   207
      TabIndex        =   0
      Top             =   240
      Width           =   3135
   End
Attribute VB_Name = "frmDIBSection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Copyright
 1997 by Desaware Inc. All Rights Reserved
Private Type BITMAPINFOHEADER '40 bytes
        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    ' RGB, so length here doesn't matter
End Type
Dim binfo As BITMAPINFO
Dim CompDC As Long  ' Compatible DC to hold the bitmap
Dim addr As Long    ' Pointer to memory block containing bitmap data
Dim DIBSectionHandle As Long    ' Handle to DIBSection
Dim OldCompDCBM As Long         ' Original bitmap for CompDC
Dim BytesPerScanLine As Long   ' Hold this value to improve performance
Private Const BI_RGB = 0&
Private Const BI_RLE8 = 1&
Private Const BI_RLE4 = 2&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private Const DIB_PAL_COLORS = 1 '  color table in palette indices
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Sub cmdWhiteRect_Click()
    Dim di&
    di = SelectObject(CompDC, GetStockObject(0))
    di = Rectangle(CompDC, 0, 0, 50, 50)
    cmdUpdate_Click
End Sub
Private Sub cmdRandom_Click()
    Dim x&
    Dim usex&, usey&
    Dim di&
    With binfo.bmiHeader
        ' Faster to access width & height in structure than pic properties
        For x& = 1 To 1000
            usex& = Int(Rnd() * .biWidth)
            ' Height can be negative for top down DIB
            usey& = Abs(Int(Rnd() * .biHeight))
            SetSectionPixel usex&, usey&, RGB(Rnd() * 256, Rnd() * 256, Rnd() * 256)
        Next x&
    End With
    cmdUpdate_Click
End Sub
Private Sub cmdStrip_Click(Index As Integer)
    StripColor Index
    cmdUpdate_Click
End Sub
Private Sub cmdUpdate_Click()
    Dim di&
    di& = BitBlt(picDisplay.hdc, 0, 0, picDisplay.ScaleWidth, picDisplay.ScaleHeight, CompDC, 0, 0, SRCCOPY)
End Sub
Private Sub Form_Load()
    Randomize
    ' Create a compatible DC to use
    CompDC = CreateCompatibleDC(0)
    ' Initialize the DIBSection header
    With binfo.bmiHeader
        .biSize = 40
        .biWidth = picDisplay.ScaleWidth
        .biHeight = -picDisplay.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24 ' True RGB
        .biCompression = BI_RGB
        ' How many bytes per scan line?
        ' For 256 colors: ScanAlign(.biWidth)
        ' For 16 colors: ScanAlign((.biWidth+1) \ 2)
        ' For monochrome: ScanAlign((.biWidth+7) \ 8)
        ' For 24 bit color, as follows:
        BytesPerScanLine = ScanAlign(.biWidth * 3)
        .biSizeImage = BytesPerScanLine * .biHeight
    End With
    DIBSectionHandle = CreateDIBSection(CompDC, binfo, DIB_RGB_COLORS, addr, 0, 0)
    OldCompDCBM = SelectObject(CompDC, DIBSectionHandle)
End Sub
' Clean up afterwards
Private Sub Form_Unload(Cancel As Integer)
    Dim di
    di = SelectObject(CompDC, OldCompDCBM)
    di = DeleteDC(CompDC)
    di = DeleteObject(DIBSectionHandle)
End Sub
' Scans must align on 32 bit boundary
Public Function ScanAlign(pwidth&) As Long
    ScanAlign = (pwidth + 3) And &HFFFFFFFC
End Function
' Calculates the location of a pixel in a DIBSection and sets it
Public Sub SetSectionPixel(ByVal x&, ByVal y&, ByVal color&)
    Dim ByteOffset&
    ' How would you modify this code for a 16 color, 256 color and monochrome DIB?
    ByteOffset = y * BytesPerScanLine + x * 3
    agCopyData color, ByVal (addr + ByteOffset), 3
End Sub
' This strips the Red, Green or Blue component from the image
' Could you do this in other color modes?
Public Sub StripColor(ByVal colorindex%)
    Dim ByteOffset&
    Dim cury&
    Dim curx&
    Dim ScanOffset&
    Dim CurrentAddr&
    Dim ByteToStrip%
    ' Reorder to match organization of bytes in DIB
    Select Case colorindex
        Case 0  ' Red
                ByteToStrip = 2
        Case 1  ' Green
                ByteToStrip = 1
        Case 2  ' Blue
                ByteToStrip = 0
    End Select
    Dim zerobyte As Byte
    ' We need to scan each line
    ' Note how we hand optimize the code to reduce calculations
    ScanOffset = addr   ' First scan line
    With binfo.bmiHeader
        For cury& = 0 To Abs(.biHeight) - 1
            ' Take into account which byte we are clearing here
            CurrentAddr& = ScanOffset& + ByteToStrip
            For curx& = 0 To .biWidth - 1
                ' Clear one byte
                agCopyData zerobyte, ByVal CurrentAddr&, 1
                CurrentAddr = CurrentAddr + 3
            Next curx&
        ScanOffset& = ScanOffset& + BytesPerScanLine
        Next cury&
    End With

End Sub
Private Sub picDisplay_Paint()
    cmdUpdate_Click
End Sub