vbAccelerator - Contents of code file: Gfx_CountColors_frmCountColours.frm

VERSION 5.00
Begin VB.Form frmCountColours 
   Caption         =   "Colour Counting"
   ClientHeight    =   3405
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   Icon            =   "frmCountColours.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3405
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdLoad 
      Caption         =   "&Load..."
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   3600
      TabIndex        =   2
      Top             =   60
      Width           =   1035
   End
   Begin VB.PictureBox picImage 
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2955
      Left            =   60
      ScaleHeight     =   2895
      ScaleWidth      =   3435
      TabIndex        =   1
      Top             =   60
      Width           =   3495
   End
   Begin VB.CommandButton cmdCount 
      Caption         =   "&Count Colours"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   3600
      TabIndex        =   0
      Top             =   720
      Width           =   1035
   End
   Begin VB.Label lblSize 
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   60
      TabIndex        =   3
      Top             =   3120
      Width           =   4575
   End
End
Attribute VB_Name = "frmCountColours"
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 "msvbvm50.dll" Alias "VarPtr" (Ptr()
 As Any) As Long

Private m_cDib As New cDibSection

Private Sub pLoad(ByVal sFIle As String)
Dim oPic As StdPicture
   Set oPic = LoadPicture(sFIle)
   m_cDib.CreateFromPicture oPic
   picImage.Picture = oPic
   lblSize.Caption = sFIle & " (" & m_cDib.Width & " x " & m_cDib.Height & ")"
End Sub

Private Sub cmdLoad_Click()
   Dim cD As New GCommonDialog
   Dim sFIle As String
   If (cD.VBGetOpenFileName( _
         Filename:=sFIle, _
         Filter:="All Picture Files
          (*.BMP;*.JPG;*.GIF)|*.BMP;*.JPG;*.GIF|Bitmaps (*.BMP)|*.BMP|JPEGs
          (*.JPG)|*.JPG|GIFs (*.GIF)|*.GIF|All Files (*.*)|*.*", _
         Owner:=Me.hwnd)) Then
      pLoad sFIle
   End If
End Sub

Private Sub cmdCount_Click()
   Dim i As Long
   Dim cGreen(0 To 255) As cIndexCollection2
   For i = 0 To 255
      Set cGreen(i) = New cIndexCollection2
      cGreen(i).AllocationSize = 32
   Next i
   
   Dim tSA As SAFEARRAY2D
   Dim bDib() As Byte
   With tSA
      .cbElements = 1
      .cDims = 2
      .Bounds(0).cElements = m_cDib.Height
      .Bounds(0).lLbound = 0
      .Bounds(1).cElements = m_cDib.BytesPerScanLine
      .Bounds(1).lLbound = 0
      .pvData = m_cDib.DIBSectionBitsPtr
   End With
   
   CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
   
   Dim x As Long, y As Long, xEnd As Long
   Dim lC As Long, lGray As Long
   Dim lInsertIndex As Long
   xEnd = (m_cDib.Width - 1) * 3
   For x = 0 To xEnd Step 3
      For y = 0 To m_cDib.Height - 1
         lC = bDib(x, y) + bDib(x + 2, y) * &H100&
         If (cGreen(bDib(x + 1, y)).BinarySearch(lC, lInsertIndex) = 0) Then
            cGreen(bDib(x + 1, y)).Add lC, lInsertIndex
         End If
      Next y
   Next x
   
   CopyMemory ByVal VarPtrArray(bDib()), 0&, 4
   
   lC = 0
   For i = 0 To 255
      lC = lC + cGreen(i).Count
   Next i
   MsgBox "The number of unique colours in this image is " & lC, vbInformation
   
End Sub

Private Sub Form_Load()
Dim sFIle As String
   sFIle = App.Path
   If (Right$(sFIle, 1) <> "\") Then sFIle = sFIle & "\"
   sFIle = sFIle & "MrBing.jpg"
   pLoad sFIle
End Sub