Const BI_RGB = 0&
Const DIB_RGB_COLORS = 0&
Const DIB_PAL_COLORS = 1&
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 PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(lpvDest As Any, lpvSource As Any, ByVal cbCopy 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
Private Declare Function SetDIBits Lib "gdi32" _
(ByVal hdc 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
Private Declare Function GetNearestPaletteIndex Lib "gdi32.dll" _
(ByVal HPALETTE As Long, ByVal crColor As Long) As Long
Private Declare Function CreatePalette Lib "gdi32" _
(lpLogPalette As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Sub ReduireNombreCouleurs(PicDest As PictureBox, palette() As Long)
Dim bw As Integer
Dim bh As Integer
Dim NColor As Integer
Dim x As Integer
Dim y As Integer
Dim hPal As Long
Dim Logpal As LOGPALETTE
Dim Bmp As BITMAPINFO
bw = PicDest.ScaleWidth
bh = PicDest.ScaleHeight
With Bmp.bmiHeader
.biSize = 40
.biWidth = bw
.biHeight = -bh
.biPlanes = 1
.biCompression = BI_RGB
.biBitCount = 32
End With
ReDim pix(bw - 1, bh - 1) As Long
GetDIBits PicDest.hdc, PicDest.Image, 0, bh, pix(0, 0), Bmp, DIB_RGB_COLORS
NColor = (UBound(palette) + 1)
If NColor > 256 Then NColor = 256
Logpal.palVersion = &H300
Logpal.palNumEntries = NColor
CopyMemory Logpal.palPalEntry(0), palette(0), NColor * 4
hPal = CreatePalette(Logpal)
'// attention le Rouge et le Bleu sont inversés
'// pour la recherche ça n'a aucune importance
'// mais pour comparer une couleur faudra en tenir compte
'// &HFF0000 représente le Rouge et &H0000FF représente le Bleu
For y = 0 To bh - 1
For x = 0 To bw - 1
pix(x, y) = palette(GetNearestPaletteIndex(hPal, pix(x, y)))
Next
Next
DeleteObject hPal
SetDIBits PicDest.hdc, PicDest.Image, 0, bh, pix(0, 0), Bmp, DIB_RGB_COLORS
PicDest.Picture = PicDest.Image
Beep
End Sub
'// UTILISATION:
'// il faut: - une PictureBox avec une image
'// - une palette de couleurs (pas plus de 256 couleurs)
'// 1er exemple:
'// création d'une palette de 256 couleurs au hasard
'// les couleurs sont dans le format RVB
'// la palette n'est pas optimisée, les doubles ne sont pas traités
Private Sub Command1_Click()
Dim pal1() As Long
Dim NbCol As Integer
Dim i As Integer
Picture1.Picture = LoadPicture(VotreImage)
Randomize Timer
NbCol = 256
ReDim pal1(NbCol - 1)
For i = 0 To NbCol - 1
pal1(i) = Rnd * 255 * 65536 + Rnd * 255 * 256 + Rnd * 255
Next
ReduireNombreCouleurs Picture1, pal1()
End Sub
'// 2ème exemple:
'// création d'une palette de 256 couleurs en niveau de gris
'// toutes les couleurs sont présentes et pas de doubles
Private Sub Command2_Click()
Dim pal2() As Long
Dim NbCol As Integer
Dim i As Integer
Picture1.Picture = LoadPicture(VotreImage)
NbCol = 256
ReDim pal2(NbCol - 1)
For i = 0 To NbCol - 1
pal2(i) = i * 65793
Next
ReduireNombreCouleurs Picture1, pal2()
End Sub
'// 3ème exemple:
'// création d'une palette de 16 couleurs en niveau de gris
'// la palette n'est pas optimisée, les doubles ne sont pas traités
Private Sub Command3_Click()
Dim Pal3() As Long
Dim NbCol As Integer
Dim i As Integer
Picture1.Picture = LoadPicture(VotreImage)
Randomize Timer
NbCol = 16
ReDim Pal3(NbCol - 1)
For i = 0 To NbCol - 1
Pal3(i) = Int(Rnd * 256) * 65793
Next
ReduireNombreCouleurs Picture1, Pal3()
End Sub