GFDIBits/Form1.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   5535
   ClientLeft      =   60
   ClientTop       =   405
   ClientWidth     =   4395
   LinkTopic       =   "Form1"
   ScaleHeight     =   5535
   ScaleWidth      =   4395
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.PictureBox Picture2
      Height          =   2590
      Left            =   0
      Picture         =   "Form1.frx":0000
      ScaleHeight     =   169
      ScaleMode       =   3 'Pixel
      ScaleWidth      =   289
      TabIndex        =   1
      ToolTipText     =   "Jack, www.toricxs.com/the_team/the_team.html"
      Top             =   480
      Width           =   4395
   End
   Begin VB.PictureBox Picture1
      Height          =   2422
      Left            =   0
      ScaleHeight     =   2355
      ScaleWidth      =   4335
      TabIndex        =   2
      Top             =   3120
      Width           =   4395
   End
   Begin VB.CommandButton Command1
      Caption         =   "get, manipulate and set DIBits"
      Height          =   375
      Left            =   56
      TabIndex        =   0
      Top             =   60
      Width           =   4275
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2003 by Louis. Use the GFDIBits functions to 'dissolve' a picture for manipulating its color values.
'NOTE: from http://www.allapi.net/. View also GetDIBits.vbp in Test Programs\.
'NOTE: further data from www.vb‑helper.com.
'
'Downloaded from www.louis‑coder.com.
'Demonstrates how to use GetDIBits()/SetDIBits(). With GetDIBits() you can easily get
'a color look‑up table from a Windows DC. SetDIBits() can be used to quickly set the image
'visible on the screen, e.g. calculate a 3D picture in memory (ColorArray()) and write it to the DC.
'
'GFDIBits_Dissolve
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC 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 Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
'GFDIBits_Dissolve
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 'color table in format RGB
'GFDIBits_Dissolve
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
'GFDIBits_Dissolve
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
'GFDIBits_Dissolve
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Sub Command1_Click()
    'on error resume next
    Dim ColorArray() As Byte
    Dim Temp1 As Long
    Dim Temp2 As Long
    Dim TempByte As Byte
    'begin
    Call GFDIBits_Dissolve(Picture2, Picture2.ScaleWidth, Picture2.ScaleHeight, ColorArray())
    '
    For Temp1 = 1 To Picture2.ScaleWidth
        For Temp2 = 1 To Picture2.ScaleHeight
            TempByte = ColorArray(1, Temp1, Temp2)
            ColorArray(1, Temp1, Temp2) = ColorArray(3, Temp1, Temp2)
            ColorArray(3, Temp1, Temp2) = TempByte
        Next Temp2
    Next Temp1
    '
    Call GFDIBits_Melt(Picture1, Picture2.ScaleWidth, Picture2.ScaleHeight, ColorArray())
End Sub

Private Function GFDIBits_Dissolve(ByVal DissolvePictureBox As PictureBox, ByVal XSize As Long, ByVal YSize As Long, ByRef ColorArray() As Byte) As Boolean
    'on error resume next 'fills passed array with PictureBox color data; returns true for success or False for error
    Dim BITMAPINFOVar As BITMAPINFO
    '
    'NOTE: ColorArray() format:
    'ColorArray(1, X, Y): Blue component of pixel (X, Y)
    'ColorArray(2, X, Y): Green component of pixel (X, Y)
    'ColorArray(3, X, Y): Red component of pixel (X, Y)
    'ColorArray(4, X, Y): Padding
    '
    'NOTE: function may fail if passed size values are not
    'DissolvePictureBox.ScaleWidth/DissolvePictureBox.ScaleHeight.
    '
    'preset
    With BITMAPINFOVar.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(BITMAPINFOVar.bmiHeader)
        .biWidth = XSize
        .biHeight = ‑YSize 'negative value to scan top‑down
        .biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4) * Abs(.biHeight)
    End With
    ReDim ColorArray(1 To 4, 1 To BITMAPINFOVar.bmiHeader.biWidth, 1 To Abs(BITMAPINFOVar.bmiHeader.biHeight)) As Byte
    'begin
    If GetDIBits(DissolvePictureBox.hdc, DissolvePictureBox.Image, 0, YSize, ColorArray(1, 1, 1), BITMAPINFOVar, DIB_RGB_COLORS) = 0 Then GoTo Error: 'verify
    GFDIBits_Dissolve = True 'ok
    Exit Function
Error:
    GFDIBits_Dissolve = False 'error
    Exit Function
End Function

Private Function GFDIBits_Melt(ByVal MeltPictureBox As PictureBox, ByVal XSize As Long, ByVal YSize As Long, ByRef ColorArray() As Byte) As Boolean
    'on error resume next 'returns True for success, False if an error occurred
    Dim BITMAPINFOVar As BITMAPINFO
    'preset
    With BITMAPINFOVar.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(BITMAPINFOVar.bmiHeader)
        .biWidth = XSize
        .biHeight = ‑YSize 'scan top‑down
        .biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4) * Abs(.biHeight)
    End With
    'begin
    GFDIBits_Melt = Not (SetDIBitsToDevice(MeltPictureBox.hdc, 0, 0, XSize, YSize, 0, 0, 0, YSize, ColorArray(1, 1, 1), BITMAPINFOVar, DIB_RGB_COLORS) = 0)
End Function


[END OF FILE]