'/////////////////////////////////////////////////
'// le but est de générer une palette optimisée //
'// à partir d'une image donnée //
'// avec un nombre de couleurs limité //
'// la méthode utilisé ici est un octree //
'// un arbre dont chaque noeud possède 8 fils //
'/////////////////////////////////////////////////
Const BI_RGB = 0&
Const DIB_RGB_COLORS = 0&
Const C08 = 256&
Const C16 = 65536
Private Type BITMAPINFOHEADER
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
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type tNode ' OCT-TREE structure
vRed As Long ' Rouge
vGreen As Long ' Vert
vBlue As Long ' Bleu
cClrs As Long ' nombre de Pixels
iChildren(7) As Long ' pointeur sur enfant
iNext As Long ' pointeur sur suivant
bIsLeaf As Boolean ' marque de feuille
bAddedReduce As Boolean ' marque de chainage
End Type
Dim aNodes() As tNode
Dim aReduce() As Long
Dim cNodes As Long
Dim TopGarbage As Long
Dim cClr As Long
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
Public Sub pvOctree(PicSRC As PictureBox, NombreCouleur As Integer, palette() As Long)
Dim bw As Long
Dim bh As Long
Dim x As Long
Dim y As Long
Dim n As Long
Dim Red As Byte
Dim Green As Byte
Dim Blue As Byte
Dim Bmp As BITMAPINFO
If NombreCouleur < 8 Then NombreCouleur = 8
If NombreCouleur > 256 Then NombreCouleur = 256
ReDim aNodes(1 To 50)
ReDim aReduce(1 To 8)
cNodes = 1
TopGarbage = 0
cClr = 0
bw = PicSRC.ScaleWidth
bh = PicSRC.ScaleHeight
With Bmp.bmiHeader
.biSize = 40
.biWidth = bw
.biHeight = -bh
.biPlanes = 1
.biCompression = BI_RGB
.biBitCount = 32
End With
ReDim pix(0 To 3, bw - 1, bh - 1) As Byte
GetDIBits PicSRC.hdc, PicSRC.Image, 0, bh, pix(0, 0, 0), Bmp, DIB_RGB_COLORS
For y = 0 To bh - 1
For x = 0 To bw - 1
Call pvAdd(pix(0, x, y), pix(1, x, y), pix(2, x, y))
Next x
Next y
Do While cClr > NombreCouleur
If pvCombineNodes = False Then Exit Do
Loop
ReDim palette(NombreCouleur - 1)
For y = 1 To UBound(aNodes)
If aNodes(y).bIsLeaf Then
With aNodes(y)
Blue = .vBlue / .cClrs
Green = .vGreen / .cClrs
Red = .vRed / .cClrs
palette(n) = Blue * C16 + Green * C08 + Red
n = n + 1
End With
End If
Next
End Sub
Private Sub pvAdd(Rx As Byte, Vx As Byte, Bx As Byte)
Dim vMid As Byte
Dim iR As Integer
Dim iG As Integer
Dim iB As Integer
Dim vMinR As Integer
Dim vMaxR As Integer
Dim vMinV As Integer
Dim vMaxV As Integer
Dim vMinB As Integer
Dim vMaxB As Integer
Dim ii As Long
Dim iIndex As Long
Dim Child As Long
Dim nLevel As Long
Child = 1
vMinR = 0: vMaxR = 255
vMinV = 0: vMaxV = 255
vMinB = 0: vMaxB = 255
For nLevel = 1 To 8
vMid = (vMinR + vMaxR) \ 2
If (Rx > vMid) Then iR = 1: vMinR = vMid + 1 Else iR = 0: vMaxR = vMid
vMid = (vMinV + vMaxV) \ 2
If (Vx > vMid) Then iG = 2: vMinV = vMid + 1 Else iG = 0: vMaxV = vMid
vMid = (vMinB + vMaxB) \ 2
If (Bx > vMid) Then iB = 4: vMinB = vMid + 1 Else iB = 0: vMaxB = vMid
ii = iR + iG + iB
iIndex = aNodes(Child).iChildren(ii)
If iIndex = 0 Then
iIndex = pvGetFreeNode
aNodes(Child).iChildren(ii) = iIndex
aNodes(Child).cClrs = aNodes(Child).cClrs + 1
With aNodes(iIndex)
.bIsLeaf = False
.iNext = 0
.cClrs = 0
.vRed = 0
.vGreen = 0
.vBlue = 0
End With
End If
With aNodes(iIndex)
If .bAddedReduce = False Then
.iNext = aReduce(nLevel)
aReduce(nLevel) = iIndex
.bAddedReduce = True
End If
End With
Child = iIndex
Next
With aNodes(iIndex)
If .cClrs = 0 Then cClr = cClr + 1
.bIsLeaf = True
.cClrs = .cClrs + 1
.vRed = .vRed + Rx
.vGreen = .vGreen + Vx
.vBlue = .vBlue + Bx
End With
End Sub
Private Function pvCombineNodes() As Boolean
Dim i As Integer
Dim iIndex As Long
Dim iR As Byte
Dim iG As Byte
Dim iB As Byte
Dim nR As Long
Dim nG As Long
Dim Nb As Long
Dim nPixel As Long
For i = 7 To 1 Step -1
If aReduce(i) <> 0 Then Exit For
Next
If i = 0 Then Exit Function
iIndex = aReduce(i)
aReduce(i) = aNodes(iIndex).iNext
For i = 0 To 7
If aNodes(iIndex).iChildren(i) <> 0 Then
With aNodes(aNodes(iIndex).iChildren(i))
nR = nR + .vRed
nG = nG + .vGreen
Nb = Nb + .vBlue
nPixel = nPixel + .cClrs
Call pvFreeNode(aNodes(iIndex).iChildren(i))
cClr = cClr - 1
End With
aNodes(iIndex).iChildren(i) = 0
End If
Next
cClr = cClr + 1
With aNodes(iIndex)
.cClrs = nPixel
.bIsLeaf = True
.vRed = nR
.vGreen = nG
.vBlue = Nb
End With
pvCombineNodes = True
End Function
Private Sub pvFreeNode(ByVal iNode As Long)
aNodes(iNode).iNext = TopGarbage
TopGarbage = iNode
aNodes(iNode).bIsLeaf = False
aNodes(iNode).bAddedReduce = False
cNodes = cNodes - 1
End Sub
Private Function pvGetFreeNode() As Long
Dim i As Long
Dim iR As Byte
Dim iG As Byte
Dim iB As Byte
cNodes = cNodes + 1
If TopGarbage = 0 Then
If cNodes > UBound(aNodes) Then
i = cNodes * 1.1
ReDim Preserve aNodes(1 To i)
End If
pvGetFreeNode = cNodes
Else
pvGetFreeNode = TopGarbage
TopGarbage = aNodes(TopGarbage).iNext
For i = 0 To 7
aNodes(pvGetFreeNode).iChildren(i) = 0
Next
End If
End Function
'// UTILISATION:
'// il faut une PictureBox avec une image
'// et choisir un nombre de couleur de 8 à 256
'// exemple:
Private Sub Command4_Click()
Dim Pal4() As Long
Dim NbCol As Integer
Dim i As Integer
Picture1.Picture = LoadPicture(VotreImage)
NbCol = 256
' création d'une palette 256 couleurs optimisée
pvOctree Picture1, NbCol, Pal4()
' application de cette palette sur l'image
' en utilisant le programme qui se trouve dans la catégorie GRAPHIC
ReduireNombreCouleurs Picture1, Pal4()
End Sub