vbAccelerator - Contents of code file: frmDib256.frm

VERSION 5.00
Begin VB.Form frmDIBSection 
   Caption         =   "vbAccelerator cDIBSection256 Tester"
   ClientHeight    =   7725
   ClientLeft      =   4545
   ClientTop       =   1950
   ClientWidth     =   8610
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmDib256.frx":0000
   LinkTopic       =   "Form1"
   PaletteMode     =   2  'Custom
   ScaleHeight     =   7725
   ScaleWidth      =   8610
   Begin VB.CommandButton cmdSave 
      Caption         =   "&Save"
      Height          =   435
      Left            =   120
      TabIndex        =   10
      Top             =   5940
      Width           =   1095
   End
   Begin VB.CommandButton cmdCycle 
      Caption         =   "&Cycle"
      Height          =   435
      Left            =   120
      TabIndex        =   9
      Top             =   4080
      Width           =   1095
   End
   Begin VB.CommandButton cmdPixelMelt 
      Caption         =   "Pixel &Melt"
      Height          =   435
      Left            =   120
      TabIndex        =   8
      Top             =   5280
      Width           =   1095
   End
   Begin VB.CommandButton cmdReset 
      Caption         =   "&Reset"
      Height          =   435
      Left            =   120
      TabIndex        =   7
      Top             =   4800
      Width           =   1095
   End
   Begin VB.CommandButton cmdGrayScale 
      Caption         =   "Gray Scale"
      Height          =   495
      Left            =   120
      TabIndex        =   6
      Top             =   3540
      Width           =   1095
   End
   Begin VB.CommandButton cmdDarken 
      Caption         =   "Darken"
      Height          =   495
      Left            =   120
      TabIndex        =   5
      Top             =   3000
      Width           =   1095
   End
   Begin VB.CommandButton cmdBrighten 
      Caption         =   "Brighten"
      Height          =   495
      Left            =   120
      TabIndex        =   4
      Top             =   2460
      Width           =   1095
   End
   Begin VB.CommandButton cmdInvert 
      Caption         =   "&Invert"
      Height          =   495
      Left            =   120
      TabIndex        =   3
      Top             =   1920
      Width           =   1095
   End
   Begin VB.CommandButton cmdChange 
      Caption         =   "Change Colour"
      Height          =   555
      Left            =   120
      TabIndex        =   2
      Top             =   1140
      Width           =   1095
   End
   Begin VB.CommandButton cmdFading 
      Caption         =   "Fade in and ou&t"
      Height          =   555
      Left            =   120
      TabIndex        =   1
      Top             =   540
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "fps"
      Height          =   195
      Left            =   180
      TabIndex        =   0
      Top             =   60
      Width           =   3735
   End
End
Attribute VB_Name = "frmDIBSection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cDibIn As New cDIBSection256
Private m_cDibOut As New cDIBSection256
Private m_pic As StdPicture

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal
 un1 As Long, ByVal un2 As Long, pRGBQuad As Any) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal
 un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Sub cmdBrighten_Click()
   m_cDibIn.AdjustLightness 110
   If (cmdFading.Caption = "Fade in and ou&t") Then
      m_cDibIn.PaintPicture Me.hdc, 96, 32
   End If
End Sub

Private Sub cmdChange_Click()
Static bFlip As Boolean
   If bFlip Then
      m_cDibIn.Color(10) = RGB(4, 4, 4)
   Else
      m_cDibIn.Color(10) = RGB(86, 31, 255)
   End If
   bFlip = Not (bFlip)
   If (cmdFading.Caption = "Fade in and ou&t") Then
      m_cDibIn.PaintPicture Me.hdc, 96, 32
   End If
End Sub

Private Sub cmdCycle_Click()
Static tRGBSwap As RGBQUAD
Static tRGB(0 To 255) As RGBQUAD
Static i As Long
Static lC As Long
Static bGo As Boolean

   If (cmdCycle.Caption = "&Stop") Then
      bGo = False
      cmdCycle.Caption = "&Cycle"
   Else
      cmdCycle.Caption = "&Stop"
      bGo = True
   End If
   
   Do While bGo
      lC = GetDIBColorTable(m_cDibIn.hdc, 0, 256, tRGB(0))
      If lC = 256 Then
         LSet tRGBSwap = tRGB(0)
         For i = 1 To 255
            LSet tRGB(i - 1) = tRGB(i)
         Next i
         tRGB(255) = tRGBSwap
         SetDIBColorTable m_cDibIn.hdc, 0, 256, tRGB(0)
         m_cDibIn.PaintPicture Me.hdc, 96, 32
      End If
      DoEvents
   Loop

End Sub

Private Sub cmdDarken_Click()
   m_cDibIn.AdjustLightness 90
   If (cmdFading.Caption = "Fade in and ou&t") Then
      m_cDibIn.PaintPicture Me.hdc, 96, 32
   End If
End Sub

Private Sub cmdFading_Click()
Static i As Long
Static lTime As Long
Dim lFrames As Long
Dim lAmount As Long, lDir As Long

   If (cmdFading.Caption <> "Fade in and ou&t") Then
      cmdFading.Caption = "Fade in and ou&t"
      m_cDibIn.PaintPicture Me.hdc, 96, 32
   Else
      cmdFading.Caption = "Stop"

      
      lAmount = 255: lDir = -4
      Do While cmdFading.Caption = "Stop"
      
         If (timeGetTime - lTime) > 1000 Then
             Label1.Caption = m_cDibIn.Width & "x" & m_cDibIn.Height & ": " &
              lFrames & "/second"
             lFrames = 0
             lTime = timeGetTime
         Else
             lFrames = lFrames + 1
         End If
      
         ' Ensure palette is restored:
         m_cDibOut.CopyPalette m_cDibIn
         ' Fade the palette appropriately:
         m_cDibOut.Fade lAmount
         ' Show the new version of the picture:
         m_cDibOut.PaintPicture Me.hdc, 96, 32
   
         lAmount = lAmount + lDir
         If (lAmount < 0) Then
            lDir = 4
            lAmount = 3
         ElseIf (lAmount = 255) Then
            lDir = -4
            lAmount = 255 - 4
         End If
         DoEvents
         
      Loop
      
   End If
End Sub

Private Sub cmdGrayScale_Click()
   m_cDibIn.GrayScale
   If (cmdFading.Caption = "Fade in and ou&t") Then
      m_cDibIn.PaintPicture Me.hdc, 96, 32
   End If
End Sub

Private Sub cmdInvert_Click()
   m_cDibIn.Invert
   If (cmdFading.Caption = "Fade in and ou&t") Then
      m_cDibIn.PaintPicture Me.hdc, 96, 32
   End If

End Sub

Private Sub cmdPixelMelt_Click()
Dim cDibOut As cDIBSection256
Dim lTime As Long
Dim lFrames As Long
   If cmdPixelMelt.Caption = "Pixel &Melt" Then
      cmdPixelMelt.Caption = "&Stop"
      Set cDibOut = New cDIBSection256
      cDibOut.Create m_cDibIn.Width, m_cDibIn.Height
      cDibOut.CopyPalette m_cDibIn
   Else
      cmdPixelMelt.Caption = "Pixel &Melt"
   End If
   lTime = timeGetTime
   Do While cmdPixelMelt.Caption = "&Stop"
      If (timeGetTime - lTime) > 1000 Then
         Label1.Caption = m_cDibIn.Width & "x" & m_cDibIn.Height & ": " &
          lFrames & "/second"
         lFrames = 0
         lTime = timeGetTime
      Else
         lFrames = lFrames + 1
      End If
      
      Init
      PixelMelt m_cDibIn, cDibOut
      cDibOut.PaintPicture Me.hdc, 96, 32
      cDibOut.PaintPicture m_cDibIn.hdc
      DoEvents
   Loop
   
End Sub

Private Sub cmdReset_Click()
Dim sFile As String

   If (cmdFading.Caption <> "Fade in and ou&t") Then
      cmdFading_Click
   End If
   Me.Palette = m_pic
   m_cDibIn.CreateFromPicture m_pic
   m_cDibIn.PaintPicture Me.hdc, 96, 32
   
End Sub

Private Sub cmdSave_Click()
Dim sI As String
   sI = InputBox$("Enter the name to save this picture as a Windows 256 colour
    bitmap to", , App.Path & "\temp256.bmp")
   If Not (sI = "") Then
      m_cDibIn.SavePicture sI
   End If
End Sub

Private Sub Form_Load()
Dim sFile As String

   sFile = App.Path & "\vbaccel2.gif"
   Set m_pic = LoadPicture(sFile)
   m_cDibIn.CreateFromPicture m_pic
   Me.Palette = m_pic
         
   ' Make a copy of cDibIn from cDibOut:
   m_cDibOut.Create m_cDibIn.Width, m_cDibIn.Height
   m_cDibOut.LoadPictureBlt m_cDibIn.hdc

   Me.Show
   Me.Refresh
   m_cDibIn.PaintPicture Me.hdc, 96, 32

End Sub