vbAccelerator - Contents of code file: frmAlphaTest.frm

VERSION 5.00
Begin VB.Form frmAlphaTest 
   AutoRedraw      =   -1  'True
   Caption         =   "Alpha DIB Section Tester"
   ClientHeight    =   7080
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7350
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmAlphaTest.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   472
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   490
   StartUpPosition =   3  'Windows Default
   Begin VB.CheckBox chkColourised 
      Caption         =   "&Colourise"
      Height          =   255
      Left            =   5040
      TabIndex        =   3
      Top             =   2160
      Width           =   1635
   End
   Begin VB.CheckBox chkEnabled 
      Caption         =   "&Enabled"
      Height          =   255
      Left            =   5040
      TabIndex        =   2
      Top             =   1860
      Value           =   1  'Checked
      Width           =   1635
   End
   Begin VB.PictureBox picAlphaButton 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   1335
      Left            =   5100
      ScaleHeight     =   89
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   93
      TabIndex        =   1
      ToolTipText     =   "Click for vbAccelerator.com"
      Top             =   420
      Width           =   1395
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "&Save..."
      Height          =   435
      Left            =   1320
      TabIndex        =   0
      Top             =   6420
      Width           =   1335
   End
   Begin VB.Label lblAlphaButton 
      Caption         =   "Alpha Button Demonstration:"
      Height          =   255
      Left            =   5040
      TabIndex        =   8
      Top             =   120
      Width           =   2175
   End
   Begin VB.Label lblFaded 
      Caption         =   "Faded Alpha Blend:"
      Height          =   555
      Left            =   120
      TabIndex        =   7
      Top             =   1620
      Width           =   975
   End
   Begin VB.Label lblFullAlpha 
      Caption         =   "Normal Alpha Blend:"
      Height          =   555
      Left            =   120
      TabIndex        =   6
      Top             =   960
      Width           =   975
   End
   Begin VB.Label lblMask 
      Caption         =   "Alpha Channel:"
      Height          =   435
      Left            =   120
      TabIndex        =   5
      Top             =   540
      Width           =   975
   End
   Begin VB.Label lblImage 
      Caption         =   "Image:"
      Height          =   315
      Left            =   120
      TabIndex        =   4
      Top             =   120
      Width           =   975
   End
End
Attribute VB_Name = "frmAlphaTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr()
 As Any) As Long

Private m_cMask As New cAlphaDibSection
Private m_cImage As New cAlphaDibSection
Private m_cAlphaImage As New cAlphaDibSection

Private WithEvents m_cAlphaButton As cAlphaButton
Attribute m_cAlphaButton.VB_VarHelpID = -1

Private Sub createAlphaImage()
   
   ' Load picture:
   m_cImage.CreateFromPicture LoadPicture(App.Path & "\logo.bmp")
   
   ' Load alpha channel:
   m_cMask.CreateFromPicture LoadPicture(App.Path & "\logomask.bmp")
   
   ' Create a new image, which is just a copy of the picture
   ' in m_cImage to build the alpha version in.  Note if
   ' we didn't want to display the image without alpha later,
   ' we could just work on m_cImage directly instead.
   m_cAlphaImage.Create m_cImage.Width, m_cImage.Height
   m_cImage.PaintPicture m_cAlphaImage.hdc
   
   ' Point byte arrays at the image bits for ease of
   ' manipulation of the data:
   Dim tMask As SAFEARRAY2D
   Dim bMask() As Byte
   Dim tImage As SAFEARRAY2D
   Dim bImage() As Byte
    
    With tMask
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_cMask.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = m_cMask.BytesPerScanLine()
        .pvData = m_cMask.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bMask()), VarPtr(tMask), 4
    
    With tImage
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_cAlphaImage.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = m_cAlphaImage.BytesPerScanLine()
        .pvData = m_cAlphaImage.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
   
   Dim x As Long, y As Long
   Dim bAlpha As Long
   For y = 0 To m_cAlphaImage.Height - 1
      For x = 0 To m_cAlphaImage.BytesPerScanLine - 4 Step 4 ' each item has 4
       bytes: R,G,B,A
         ' Get the red value from the mask to use as the alpha
         ' value:
         bAlpha = bMask(x, y)
         ' Set the alpha in the alpha image..
         bImage(x + 3, y) = bAlpha
         ' Now premultiply the r/g/b values by the alpha divided
         ' by 255.  This is required for the AlphaBlend GDI function,
         ' see MSDN/Platform SDK/GDI/BLENDFUNCTION for more
         ' details:
         bImage(x, y) = bImage(x, y) * bAlpha \ 255
         bImage(x + 1, y) = bImage(x + 1, y) * bAlpha \ 255
         bImage(x + 2, y) = bImage(x + 2, y) * bAlpha \ 255
      Next x
   Next y
   
   ' Clear up the temporary array descriptors.  You
   ' only need to do this on NT but best to be safe.
   CopyMemory ByVal VarPtrArray(bMask), 0&, 4
   CopyMemory ByVal VarPtrArray(bImage), 0&, 4

   lblImage.Move 2, 2
   lblMask.Move 2, 4 + m_cAlphaImage.Height
   lblFullAlpha.Move 2, 6 + m_cAlphaImage.Height * 2
   lblFaded.Move 2, 8 + m_cAlphaImage.Height * 3

   Draw
   
End Sub

Private Sub createAlphaButton()
   Set m_cAlphaButton = New cAlphaButton
   With m_cAlphaButton
      Set .DrawObject = picAlphaButton
      If InDebug Then
         .AlphaLogoFileName = App.Path & "\res\alphalogo.bmp"
         .AlphaLogoDownFileName = App.Path & "\res\alphalogodown.bmp"
      Else
         .AlphaLogoId = 1
         .AlphaLogoDownId = 2
         .hInstance = App.hInstance
      End If
      .LoadImages
      picAlphaButton.Width = .Width
      picAlphaButton.Height = .Height
      .Draw
   End With
End Sub

Private Sub Draw()
   
   Dim x As Long
   Dim y As Long
   x = lblImage.Left + lblImage.Width
   
   ' Draw the original image:
   m_cImage.PaintPicture Me.hdc, x, 2
   ' Draw the mask:
   m_cMask.PaintPicture Me.hdc, x, m_cMask.Height + 4
   
   ' Draw the alpha version against various
   ' backgrounds and with differing constant alpha:
   y = (m_cAlphaImage.Height + 2) * 2
   Dim i As Long, lCol As Long
   For i = 1 To 4
      Select Case i
      Case 1
         lCol = vbButtonFace
      Case 2
         lCol = vbWindowBackground
      Case 3
         lCol = vb3DShadow
      Case 4
         lCol = RGB(108, 182, 255)
      End Select
      
      ' Draw backgrounds:
      Me.Line (x, y)-(x + m_cAlphaImage.Width, y + m_cAlphaImage.Height), lCol,
       BF
      Me.Line (x, y + m_cAlphaImage.Height + 2)-(x + m_cAlphaImage.Width, y +
       m_cAlphaImage.Height * 2 + 2), lCol, BF
      If (i = 3) Then
         Me.Line (x + m_cAlphaImage.Width \ 2, y + m_cAlphaImage.Height \ 2)-(x
          + m_cAlphaImage.Width, y + m_cAlphaImage.Height * 3 \ 2), RGB(255, 0,
          0), BF
      ElseIf (i = 4) Then
         Me.Line (x, y + m_cAlphaImage.Height \ 2)-(x + m_cAlphaImage.Width \
          2, y + m_cAlphaImage.Height * 3 \ 2), RGB(255, 0, 0), BF
      End If
      
      ' Draw normally, so only the drop shadow uses the alpha effect:
      m_cAlphaImage.AlphaPaintPicture Me.hdc, x, y
      
      ' Apply a constant alpha of 64 so all parts of the image, including the
      ' drop shadow, are ghosted:
      m_cAlphaImage.AlphaPaintPicture Me.hdc, x, y + m_cAlphaImage.Height + 2,
       lConstantAlpha:=64
      
      x = x + m_cAlphaImage.Width + 2
   Next i
   
   Me.Refresh
End Sub

Private Sub chkColourised_Click()
   If (chkColourised.value = vbChecked) Then
      m_cAlphaButton.Colourise 0.2
   Else
      m_cAlphaButton.Colourise 3.5
   End If
End Sub

Private Sub chkEnabled_Click()
   m_cAlphaButton.Enabled = (chkEnabled.value = vbChecked)
End Sub

Private Sub cmdSave_Click()
Dim sI As String
   sI = InputBox("Please enter the name to save the alpha image to:",
    App.Title, App.Path & "\alphalogo.bmp")
   If (Len(sI) > 0) Then
      m_cAlphaImage.SavePicture sI
   End If
End Sub

Private Sub Form_Load()
   createAlphaButton
   createAlphaImage
End Sub


Private Sub Form_Resize()
   Draw
End Sub

Private Sub m_cAlphaButton_Click()
   MsgBox "Button Clicked", vbInformation
End Sub

Private Sub picAlphaButton_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   m_cAlphaButton.MouseDown Button, Shift, x, y
End Sub

Private Sub picAlphaButton_MouseMove(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   m_cAlphaButton.MouseMove Button, Shift, x, y
End Sub

Private Sub picAlphaButton_MouseUp(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   m_cAlphaButton.MouseUp Button, Shift, x, y
End Sub