'// Vous pouvez modifier ces 2 paramètres à votre convenance:
Const Taille = 128 'taille en pixels pour une icone
Const NbIcon = 5 'le nombre d'icones par ligne
Const BI_RGB = 0&
Const DIB_RGB_COLORS = 0&
Private Type ICONFILEHEADER 'Taille = 6 bytes
idReserved As Integer 'toujours à zéro
idType As Integer '1=icone 2=curseur
idCount As Integer 'nombre d'icones
End Type
Private Type ICONDIRECTORYENTRY 'Taille = 16 bytes
bwidth As Byte 'Largeur de l'icone
bheight As Byte 'Hauteur de l'icone
bColorCount As Byte 'nombre de couleurs (2,16,0) ou (ce qu'on veut ?)
bReserved As Byte 'toujours à zéro
wPlanes As Integer 'nb de plan = 1
wBitCount As Integer 'Nombre de bits (1,4,8,24,32)
dwBytesInRes As Long 'taille icone (40 + TdC + tdI + TdM)
dwImageOffset As Long 'adresse de l'icone
End Type
Private Type BITMAPINFOHEADER 'Taille = 40 bytes
biSize As Long 'taille = 40
biWidth As Long 'Largeur
biHeight As Long 'Hauteur * 2
biPlanes As Integer 'nb de plan = 1
biBitCount As Integer '1=mono, 4=16 couleurs, 8=256 couleurs, 24=true couleur, 32=true XP
biCompression As Long ' = 0
biSizeImage As Long 'taille image (avec masque ? pas toujours)
biXPelsPerMeter As Long ' = 0
biYPelsPerMeter As Long ' = 0
biClrUsed As Long ' = 0
biClrImportant As Long ' = 0
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 ICONE 'Taille = 20 Bytes
adresse As Long 'Adresse de l'icone
longueur As Long 'Taille icone (40+TdC+TdI+TdM)
TdC As Long 'taille de la Palette
bwidth As Integer 'Largeur de l'icone
bheight As Integer 'Hauteur de l'icone
Nbit As Integer 'Nombre de bits (1,4,8,24,32)
NColor As Integer 'Nombre de couleurs (2,16,256)
BwSL As Integer 'Longeur d'une Ligne pour l'image
BwMK As Integer 'Longeur d'une Ligne pour le masque
End Type
'Tables
Dim Param() As ICONE
Dim XIDE() As Byte
'Paramètres pour l'icone sélectionnée
Dim Pt As Long 'Adresse de l'icone
Dim bw As Long 'Largeur de l'icone
Dim bh As Long 'Hauteur de l'icone
Dim BwSL As Integer 'Longeur d'une Ligne pour l'image
Dim BwMK As Integer 'Longeur d'une Ligne pour le masque
Dim Nbit As Integer 'Nombre de bits (1,4,8,24,32)
Dim NColor As Integer 'Nombre de couleurs (2,16,256)
Dim Nb As Integer
Dim PosX As Integer
Dim PosY As Integer
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SetDIBitsToDevice Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, _
ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, _
Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Sub Form_Load()
Me.ScaleMode = 3
Me.BackColor = vbButtonFace
Picture1(0).Visible = False
Picture1(0).Appearance = 0
Picture1(0).BorderStyle = 0
Picture1(0).AutoRedraw = True
ReadIcon
End Sub
Private Sub ReadIcon()
Dim Ifh As ICONFILEHEADER
Dim Ide As ICONDIRECTORYENTRY
Dim Bmp As BITMAPINFOHEADER
Dim Nom As String
Dim i As Integer
Dim W As Integer
Dim Lf As Long
Dim Lg As Long
Dim Lz As Long
Dim t1 As Long
Dim y1 As Long
Dim y2 As Long
Dim p1 As Long
Dim p2 As Long
Dim Lt As Long
Dim TdC As Long
Dim Temp() As Byte
Dim tmp() As Byte
' CDial.InitDir = "C:\ICONES\" 'ce que vous voulez
CDial.Filter = "Icones(*.ico)|*.ico"
CDial.FilterIndex = 1
CDial.CancelError = True
CDial.Flags = cdlOFNFileMustExist
On Error GoTo Error
CDial.ShowOpen
Nom = CDial.FileName
Lf = FileLen(Nom)
If Lf < 82 Then GoTo Err1
Open Nom For Binary As #1
Lf = Lf - 1: ReDim Temp(Lf): Lf = Lf - 56
Get #1, , Temp()
Close #1
CopyMemory Ifh, Temp(0), 6
If Ifh.idReserved <> 0 Then GoTo Err1
If Ifh.idType <> 1 Then GoTo Err1
For i = 1 To Nb: Unload Picture1(i): Next
Lg = 5: Nb = 0: t1 = 6
For i = 1 To Ifh.idCount
CopyMemory Ide, Temp(t1), 16
Pt = Ide.dwImageOffset
bw = Ide.bwidth
bh = Ide.bheight
Lt = Ide.dwBytesInRes
If Pt > Lf Then
MsgBox "Erreur ImageOffset pour icone " & i
GoTo Suite
End If
CopyMemory Bmp, Temp(Pt), 16
If Bmp.biSize <> 40 Then
MsgBox "Erreur Size pour icone " & i
GoTo Suite
End If
Nbit = Bmp.biBitCount
BwMK = ((bw + 31) \ 32) * 4
If Nbit = 1 Then NColor = 2: TdC = 8: BwSL = BwMK
If Nbit = 4 Then NColor = 16: TdC = 64: BwSL = ((bw + 7) \ 8) * 4
If Nbit = 8 Then NColor = 256: TdC = 1024: BwSL = ((bw + 3) \ 4) * 4
If Nbit = 24 Then NColor = 0: TdC = 0: BwSL = bw * 3 + (bw Mod 4)
If Nbit = 32 Then NColor = 0: TdC = 0: BwSL = bw * 4
If Lt <> 40 + TdC + CLng(bh) * BwSL + bh * BwMK Then
MsgBox "Erreur BytesInRes pour icone " & i
GoTo Suite
End If
Nb = Nb + 1
ReDim Preserve XIDE(Lg + Lt + 16)
ReDim Preserve Param(Nb)
y2 = 2: p1 = 22: p2 = 0
For W = 1 To Nb - 1
p1 = Param(W).adresse + 16
p2 = Param(W).longueur
Param(W).adresse = p1
y2 = y2 + 16
CopyMemory XIDE(y2), p1, 4
Next
Lz = Lg - y2 - 3
Lg = Lg + Lt + 16
If Lz > 0 Then
ReDim tmp(Lz)
y1 = y2 + 4: y2 = y1 + 16
CopyMemory tmp(0), XIDE(y1), Lz
CopyMemory XIDE(y2), tmp(0), Lz
End If
p2 = p1 + p2
With Param(Nb)
.adresse = p2
.longueur = Lt
.bwidth = bw
.bheight = bh
.Nbit = Nbit
.NColor = NColor
.TdC = TdC
.BwSL = BwSL
.BwMK = BwMK
End With
Ifh.idType = 1
Ifh.idCount = Nb
CopyMemory XIDE(0), Ifh, 6
Ide.dwImageOffset = p2
p1 = Nb * 16 - 10
CopyMemory XIDE(p1), Ide, 16
CopyMemory XIDE(p2), Temp(Pt), Lt
Suite:
t1 = t1 + 16
Next
If Nb = 0 Then Exit Sub
Lg = ((Nb + NbIcon - 1) \ NbIcon) * Taille * 15 + 510
If Me.Height < Lg Then Me.Height = Lg
Lg = Taille * NbIcon * 15 + 120
If Me.Width < Lg Then Me.Width = Lg
PosX = 0: PosY = 0
For i = 1 To Nb
Load Picture1(i)
Picture1(i).Visible = True
DrawImage i
PosX = PosX + Taille
If PosX >= Taille * NbIcon Then PosX = 0: PosY = PosY + Taille
Next
Exit Sub
Error:
If Err = 32755 Then Exit Sub
MsgBox Err.Description & " (" & Err & ")", vbExclamation, "Open Erreur"
Exit Sub
Err1:
MsgBox "Ce n'est pas un fichier ico"
End Sub
Private Sub DrawImage(i As Integer)
Dim Bmp As BITMAPINFO
Dim c As Byte
Dim R As Byte
Dim V As Byte
Dim B As Byte
Dim m As Byte
Dim Xc As Byte
Dim H As Long
Dim W As Long
Dim Fi As Long
Dim Fj As Long
Dim Mi As Long
Dim Mj As Long
Dim p As Long
Dim TdC As Long
Dim x As Long
Dim Alpha As Single
With Param(i)
Pt = .adresse + 40
bw = .bwidth
bh = .bheight
Nbit = .Nbit
NColor = .NColor
TdC = .TdC
BwSL = .BwSL
BwMK = .BwMK
End With
With Bmp.bmiHeader
.biSize = 40
.biWidth = bw
.biHeight = bh
.biPlanes = 1
.biCompression = BI_RGB
.biBitCount = 32
End With
Picture1(i).Move PosX + (Taille - bw) / 2, PosY + (Taille - bh) / 2, bw, bh
ReDim Pix(4 * bw * bh - 1) As Byte
Fi = Pt + TdC
Mi = Fi + CLng(bh) * BwSL
For H = 0 To bh - 1
Fj = Fi: Mj = Mi: m = 128
For W = 0 To bw - 1
Select Case Nbit
Case 1: If XIDE(Fj) And m Then c = 1 Else c = 0
p = Pt + c * 4: If m = 1 Then Fj = Fj + 1
Case 4: Xc = XIDE(Fj)
If W Mod 2 Then
Fj = Fj + 1: c = (Xc And 15)
Else
c = (Xc And 240) \ 16
End If
p = Pt + c * 4
Case 8: c = XIDE(Fj)
p = Pt + c * 4: Fj = Fj + 1
Case 24: p = Fj: Fj = Fj + 3
Case 32: p = Fj: Fj = Fj + 4
End Select
If Nbit < 32 Then
If (XIDE(Mj) And m) = 0 Then
B = XIDE(p): V = XIDE(p + 1): R = XIDE(p + 2)
Else
B = 216: V = 233: R = 236
End If
Else
Xc = XIDE(p + 3)
If Xc > 0 Then
Alpha = Xc / 255
R = Alpha * (XIDE(p + 2) - 236) + 236
V = Alpha * (XIDE(p + 1) - 233) + 233
B = Alpha * (XIDE(p) - 216) + 216
Else
B = 216: V = 233: R = 236
End If
End If
Pix(x) = B: Pix(x + 1) = V: Pix(x + 2) = R: x = x + 4
m = m \ 2: If m = 0 Then m = 128: Mj = Mj + 1
Next
Fi = Fi + BwSL: Mi = Mi + BwMK
Next
SetDIBitsToDevice Picture1(i).hdc, 0, 0, bw, bh, 0, 0, 0, _
bh, Pix(0), Bmp, DIB_RGB_COLORS
End Sub
'// un double click sur l'icone et ... zoom
Private Sub Picture1_DblClick(Index As Integer)
bw = Picture1(Index).Width
bh = Picture1(Index).Height
Picture1(0).Picture = Picture1(Index).Image
Picture1(0).Width = bw
Picture1(0).Height = bh
PosX = Picture1(Index).Left - (Taille - bw) / 2
PosY = Picture1(Index).Top - (Taille - bh) / 2
Picture1(Index).Move PosX, PosY, Taille, Taille
StretchBlt Picture1(Index).hdc, 0, 0, Taille, Taille, _
Picture1(0).hdc, 0, 0, bw, bh, vbSrcCopy
End Sub
' pour l'ulisation il faut:
' - une PictureBox: Picture1 avec index = 0
' - un CommonDialog: CDial
' le lancement se fait par appel à ReadIcon
' vous pouvez ajouter un CommandButton
' ou par un Click sur la Forme:
Private Sub Form_Click()
ReadIcon
End Sub