VB5 DIBSection Demonstration (110K)
VB6 DIBSection Demonstration (106K)
13 Jan 2003
Cleaned up the sample and added a VB6 version, plus added a SavePicture method to natively save to a bitmap.
vbAccelerator - Contents of code file: frmDibSection.frm
VERSION 5.00
Begin VB.Form frmDIBSection
Caption = "cDIBSection Tester"
ClientHeight = 7065
ClientLeft = 3630
ClientTop = 2010
ClientWidth = 7395
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmDibSection.frx":0000
LinkTopic = "Form1"
ScaleHeight = 7065
ScaleWidth = 7395
Begin VB.CommandButton cmdSave
Caption = "&Save"
Enabled = 0 'False
Height = 435
Left = 180
TabIndex = 11
Top = 5040
Width = 1215
End
Begin VB.CheckBox chkUseDrawDIB
Caption = "Use &Draw DIB"
Height = 735
Left = 180
TabIndex = 10
Top = 4260
Width = 1275
End
Begin VB.OptionButton optSize
Caption = "512 x 512"
Height = 195
Index = 1
Left = 180
TabIndex = 9
Top = 4020
Width = 1155
End
Begin VB.OptionButton optSize
Caption = "256 x 256"
Height = 195
Index = 0
Left = 180
TabIndex = 8
Top = 3780
Value = -1 'True
Width = 1155
End
Begin VB.CommandButton cmdFade
Caption = "Fade in and ou&t"
Height = 675
Left = 180
TabIndex = 7
Top = 3060
Width = 1215
End
Begin VB.CommandButton cmdEmboss
Caption = "&Emboss"
Height = 375
Left = 180
TabIndex = 6
Top = 5760
Width = 1215
End
Begin VB.CommandButton cmdStaticFade
Caption = "&Fade in and out with static"
Height = 675
Left = 180
TabIndex = 4
Top = 2340
Width = 1215
End
Begin VB.CommandButton cmdResample
Caption = "Resam&ple"
Enabled = 0 'False
Height = 375
Left = 180
TabIndex = 3
Top = 1740
Width = 1215
End
Begin VB.CommandButton cmdAudrey
Caption = "&Load Audrey"
Height = 375
Left = 180
TabIndex = 2
Top = 1320
Width = 1215
End
Begin VB.CommandButton cmdShowStatic
Caption = "Show &Static"
Enabled = 0 'False
Height = 375
Left = 120
TabIndex = 1
Top = 540
Width = 1275
End
Begin VB.CommandButton cmdRandomDib
Caption = "&Random DIB"
Height = 375
Left = 120
TabIndex = 0
Top = 120
Width = 1275
End
Begin VB.Label Label1
Caption = "fps"
Height = 195
Left = 180
TabIndex = 5
Top = 6360
Width = 1515
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_cDIB As New cDIBSection
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Sub chkUseDrawDIB_Click()
m_cDIB.UseDrawDib = (chkUseDrawDIB.Value = Checked)
End Sub
Private Sub cmdFade_Click()
Dim cDibDisp As cDIBSection
Dim cDibPic As cDIBSection
Dim cDC As cMemDC
Dim sPic As New StdPicture
Dim lAmount As Long
Dim lTIme As Long
Dim lFrames As Long
Dim lL As Long
Dim lDir As Long
Dim sFile As String
Dim bUseMemDC As Boolean
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
If (cmdFade.Caption <> "Fade in and ou&t") Then
cmdFade.Caption = "Fade in and ou&t"
Else
cmdFade.Caption = "Stop"
If (optSize(0).Value) Then
sFile = App.Path & "\vbaccel.gif"
Else
sFile = App.Path & "\vbaccel2.jpg"
End If
Set sPic = LoadPicture(sFile)
Set cDibPic = New cDIBSection
Set cDibDisp = New cDIBSection
cDibPic.CreateFromPicture sPic
cDibDisp.Create cDibPic.Width, cDibPic.Height
lAmount = 255: lDir = -4
Do While cmdFade.Caption = "Stop"
If (timeGetTime - lTIme) > 1000 Then
Label1.Caption = cDibPic.Width & "x" & cDibPic.Height & ": " &
lFrames & "/second"
lFrames = 0
lTIme = timeGetTime
Else
lFrames = lFrames + 1
End If
DoFade cDibPic, cDibDisp, lAmount
cDibDisp.PaintPicture Me.hdc, lL, 8
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 cmdSave_Click()
Dim sFile As String
sFile = App.Path & "\testsave.bmp"
If m_cDIB.SavePicture(sFile) Then
MsgBox "Saved to " & sFile, vbInformation
End If
End Sub
Private Sub cmdRandomDib_Click()
Dim lL As Long
m_cDIB.Create 256, 256
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
m_cDIB.PaintPicture Me.hdc, lL, 8
m_cDIB.RandomiseBits 'True
m_cDIB.PaintPicture Me.hdc, lL, m_cDIB.Height + 10
cmdShowStatic.Enabled = True
cmdResample.Enabled = True
cmdSave.Enabled = True
End Sub
Private Sub cmdShowStatic_Click()
Dim lL As Long
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
If (cmdShowStatic.Caption = "Show &Static") Then
Me.Cls
cmdShowStatic.Caption = "Stop &Static"
Else
cmdShowStatic.Caption = "Show &Static"
End If
Do While cmdShowStatic.Caption = "Stop &Static"
m_cDIB.RandomiseBits True
m_cDIB.PaintPicture Me.hdc, lL, 8
DoEvents
Loop
End Sub
Private Sub cmdAudrey_Click()
Dim sPic As StdPicture
Dim lL As Long
Me.Cls
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
Set sPic = LoadPicture(App.Path & "\audrey.jpg")
m_cDIB.CreateFromPicture sPic
m_cDIB.PaintPicture Me.hdc, lL, 8
cmdResample.Enabled = True
cmdShowStatic.Enabled = True
cmdSave.Enabled = True
End Sub
Private Sub cmdResample_Click()
Dim lL As Long
Dim cDib2 As cDIBSection
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
Set cDib2 = m_cDIB.Resample(m_cDIB.Height * 1.5, m_cDIB.Width * 1.5)
Me.Cls
m_cDIB.Create cDib2.Width, cDib2.Height
cDib2.PaintPicture m_cDIB.hdc
m_cDIB.PaintPicture Me.hdc, lL, 8
End Sub
Private Sub cmdStaticFade_Click()
Dim cDibPic As cDIBSection
Dim cDibDisp As cDIBSection
Dim cDC As cMemDC
Dim lAmount As Long, lAmount2 As Long
Dim lOffset As Long
Dim lRndAmount As Long
Dim lL As Long
Dim sPic As StdPicture
Dim lTIme As Long
Dim lFrames As Long
Dim sFile As String
Dim bUseMemDC As Boolean
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
If (cmdStaticFade.Caption <> "&Fade in and out with static") Then
cmdStaticFade.Caption = "&Fade in and out with static"
Else
Me.Cls
cmdStaticFade.Caption = "Stop"
If (optSize(0).Value) Then
sFile = App.Path & "\vbaccel.gif"
Else
sFile = App.Path & "\vbaccel2.jpg"
End If
Set sPic = LoadPicture(sFile)
Set cDibPic = New cDIBSection
Set cDibDisp = New cDIBSection
cDibPic.CreateFromPicture sPic
cDibDisp.Create cDibPic.Width, cDibPic.Height
End If
lAmount2 = 255
Do While cmdStaticFade.Caption = "Stop"
If (timeGetTime - lTIme) > 1000 Then
Label1.Caption = cDibPic.Width & "x" & cDibPic.Height & ": " &
lFrames & "/second"
lFrames = 0
lTIme = timeGetTime
Else
lFrames = lFrames + 1
End If
If (lAmount < 251) Then
lAmount = lAmount + 4
DoStatic cDibPic, cDibDisp, lAmount, lOffset
Else
lAmount = 255
If (lOffset < 251) Then
lOffset = lOffset + 4
DoStatic cDibPic, cDibDisp, lAmount, lOffset
Else
lOffset = 255
If (lRndAmount < cDibPic.Height \ 6) Then
lRndAmount = lRndAmount + 1
BlowApart cDibPic, cDibDisp, lRndAmount
Else
If (lAmount2 > 16) Then
lAmount2 = lAmount2 - 8
DoStatic cDibPic, cDibDisp, lAmount2, 0
Else
' start again:
lAmount = 0: lOffset = 0: lRndAmount = 0: lAmount2 = 255
cDibPic.CreateFromPicture sPic
End If
End If
End If
End If
If (bUseMemDC) Then
cDC.LoadPictureBlt cDibDisp.hdc
cDC.PaintPicture Me.hdc, lL, 8
Else
cDibDisp.PaintPicture Me.hdc, lL, 8
End If
DoEvents
Loop
End Sub
Private Sub cmdEmboss_Click()
Dim sPic As StdPicture
Dim cBuff As New cDIBSection
Dim cIP As New cImageProcessDIB
Dim lL As Long
Me.Cls
lL = (cmdRandomDib.Left + cmdRandomDib.Width) \ Screen.TwipsPerPixelX + 16
Set sPic = LoadPicture(App.Path & "\vbaccel.gif")
m_cDIB.CreateFromPicture sPic
cBuff.Create m_cDIB.Width, m_cDIB.Height
cIP.FilterType = eEmboss
cIP.ProcessImage m_cDIB, cBuff
m_cDIB.PaintPicture Me.hdc, lL, 8
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If (cmdShowStatic.Caption = "Stop &Static") Then
MsgBox "Must stop Static demonstration first.", vbInformation
Cancel = True
End If
If (cmdStaticFade.Caption = "Stop") Then
MsgBox "Must stop Fade with Static demonstration first.", vbInformation
Cancel = True
End If
If (cmdFade.Caption = "Stop") Then
MsgBox "Must stop Fade demonstration first.", vbInformation
Cancel = True
End If
End Sub
