Créer un vrai icône (+extracteur)

Télécharger le projet
Commenter

Description

Après de longues recherches, voici enfin le code pour créer un fichier icone (ICO) valide (ben, oui, pas un BitMap avec l'extension ico)
Car la fonction SavePicture n'enregistre qu'en BMP !
..et sans API (tout à la main) !
Pour la transparence, faudra attendre un peu, encore...

Ci-joint, in le ZIP, un programme-exemple commenté d'extracteur d'icones :
Dans the ZIP (76,7 Ko = moins de 20 s) :
Alire.txt : le fichier à lire avant tout
projet3.mak : fichier de projet VB 3
appfrm3.frm : la feuille VB 3
appfrm3.frx : l'icone
mod1_3.bas : le module
eicoX_XX.exe : les 8 versions (1.0.1->1.4.0)

La source est en VB 3 mais le code est compatible VB 4, 5 ou 6 !
(il faudra peut-être changer les Integer des APIs en Long).

Source / Exemple : 


'Tout ce code est extrait du module du programme-exemple du zip.

'Appeler l'une des fonctions suivantes : SaveIcon2, SaveIcon16 ou SaveIcon256

Option Explicit

Type TYPE_PALETTE   'Pour une palette de 256 couleurs max
  n As Integer              'Nombre de couleurs
  Colors(0 To 255) As Long  'Couleurs dans un tableau
End Type            '1026 octets

Function CompteCouleursPalette& (PB As PictureBox, pPal As TYPE_PALETTE)
'Cette fonction compte le nombre de couleurs d'une image PB
'et renvoie les 256 premières couleurs dans la palette 256 couleurs pPal.
'La taille de l'image ne doit pas être trop grande,
'Sinon, ça prend du temps
'Et ça peut provoquer une erreur de dépassement de
'capacités si une image carrée dépasse 180x180 pixels
'PB.ScaleMode doit être à 3 - Pixels

'Si une erreur se produit (s'il y a plus de 256 couleurs), on continue
On Error Resume Next
'Crée un tableau avec toutes les couleurs de l'image
ReDim tCo(PB.ScaleWidth * PB.ScaleHeight - 1) As Long

Dim i&, j&, tpo&

'Pour chaque point (i;j), on met la couleur dans le tableau
For i = 0 To PB.ScaleWidth - 1
  For j = 0 To PB.ScaleHeight - 1
    tCo(i * PB.ScaleWidth + j) = PB.Point(i, j)
  Next
Next

'Pour chaque couleur, on ajoute 1 au total et on la met dans la palette
'sauf si cette couleur a déjà été comptée
tpo = 0
For i = 0 To PB.ScaleWidth * PB.ScaleHeight - 1
  For j = 0 To i - 1
    If tCo(j) = tCo(i) Then Exit For
  Next
  If i = j Then
    pPal.Colors(tpo) = tCo(i)
    tpo = tpo + 1
  End If
Next

'On retourne les valeurs
pPal.n = tpo
CompteCouleursPalette = tpo

End Function

Function GetLngEndIco (pW%, pH%)
'Permet de savoir la longueur de la partie finale d'un icone,
'la partie qui gère la transparence
    GetLngEndIco = (-Int(-((pW \ 8) / 4))) * 4 * pH
End Function

Function GetLngIco& (pW%, pH%, pProf%)
'Permet de savoir la taille d'un fichier ICO (sans la partie du début)
'On considère que les dimensions sont des dimensions
'standard (\8) d'icônes

Dim t&
Select Case pProf
    Case 1, 4, 8    '2, 16, 256 couleurs
'Dans le cas d'un ico 2, 16 ou 256 couleurs, on compte la palette + la "partie pixels"
    t = 2 ^ pProf * 4 + pW * pH / 8 * pProf
    Case 24         '16 millions de couleurs
'Dans le cas d'un ico 16M de couleurs, on compte la "partie pixels",
'chaque pixel occupe 3 octets (1 pour le Bleu (Blue, B), 1 pour le Vert (Green, G), 1 pour le Rouge (Red, R))
  t = pH * pW * 3
End Select

'+ la partie finale de "transparence"
t = t + GetLngEndIco(pW, pH)

GetLngIco = t

End Function

Function HexaToTxt$ (HexaStr$)
'Cette fonction tranforme une chaîne de caractères en une
'autre chaîne de caractères.
'La chaîne source est une chaîne contenant le code HEXA de
'chacun des caractères de l'autre. Exemple :
'HexaToTxt ("4D2042") = "M B"
'Exemples valides :            Exemples invalides :
'HexaToTxt ("FF58DB")           HexaToTxt ("FF 58 DB")
'HexaToTxt ("0000")             HexaToTxt ("")
'HexaToTxt ("11AA5522")         HexaToTxt ("11AA55223")
Dim i%, HTTStr$
HTTStr = ""
For i = 1 To (Len(HexaStr) \ 2) * 2 Step 2
    HTTStr = HTTStr & Chr$(Val("&H" & Mid$(HexaStr, i, 2)))
Next
HexaToTxt = HTTStr
End Function

Function NbrToStr$ (pN, lngBuf%)
'Transforme un nombre en chaine de caractère (binaire)
'pour qu'elle soit placée dans un fichier en tant que nombre
'pN est le nombre
'lngBuf est la longueur de la chaine obtenue
Dim i%, TMP$
TMP = ""

For i = 0 To lngBuf - 1
    TMP = TMP & Chr$(pN \ 2 ^ (i * 8) Mod 256)
Next

NbrToStr = TMP

End Function

Function NbrToStrInv$ (pN, lngBuf%)
'Voir NbrToStr()
'Sauf que l'ordre des octets est inversé (c le cas des couleurs)
Dim i%, TMP$
TMP = ""

For i = 0 To lngBuf - 1
    TMP = Chr$(pN \ 2 ^ (i * 8) Mod 256) & TMP
Next

NbrToStrInv = TMP

End Function

Sub VideFichier (pFile$)
'Cette procédure vide le fichier pFile mais ne l'efface pas

Dim f%
f = FreeFile
Open pFile For Output As #f
Close #f

End Sub

Sub SaveIcon16 (PB As PictureBox, pFile$)
'Cette procédure enregistre l'image PB en tant qu'icone
'en 16 couleurs (4 bits) dans le fichier pFile
'PB.ScaleMode doit être à 3 - Pixel
'Les dimensions doit être divisibles par 8 et inférieures
'à 180
'Si l'icone possède :..., elle est enregistrée en :
' + de 256 couleurs       16M couleurs
' + de 16 mais - de 257   256 couleurs
' - de 3 couleurs         2 couleurs

'On Error Resume Next
Dim f%, TMP$, tp&, pbH%, pbW%
Dim i%, j%, k%, l%, t2&
f = FreeFile
pbH = PB.ScaleHeight
pbW = PB.ScaleWidth

Dim fPal As TYPE_PALETTE
tp = CompteCouleursPalette(PB, fPal)
Select Case tp
  Case Is > 256     '16 millions de couleurs
    SaveIcon16M PB, pFile
    Exit Sub
  Case Is > 16       '256 couleurs
    SaveIcon256 PB, pFile
    Exit Sub
  Case Is < 3      '2 couleurs
    SaveIcon2 PB, pFile
    Exit Sub
End Select

VideFichier pFile
Open pFile For Binary As #f
TMP = HexaToTxt("000001000100")
Put #f, , TMP               'début du fichier
TMP = Chr$(pbW) & Chr$(pbH) & Chr$(16)
Put #f, , TMP               'dimensions + nombre_couleurs
TMP = String$(5, 0)
Put #f, , TMP               'point_actif
tp = GetLngIco(pbW, pbH, 4)
TMP = NbrToStr(tp + 40, 3) & Chr$(0)
Put #f, , TMP
TMP = Chr$(22) & String$(3, 0) & Chr$(40) & String$(3, 0)
Put #f, , TMP
TMP = Chr$(pbW) & String$(3, 0)
Put #f, , TMP
TMP = NbrToStr(pbH * 2, 2) & String$(2, 0)
Put #f, , TMP
TMP = HexaToTxt("010004") & String$(5, 0)
Put #f, , TMP
TMP = NbrToStr(tp, 3) & String$(17, 0)
Put #f, , TMP

For i = 0 To 15    'Impression de la palette
    TMP = NbrToStrInv(fPal.Colors(i), 3) & Chr$(0)
    Put #f, , TMP
Next
''''''''''Fin de l'intro, ouf !'''''''''''
tp = pbW - 1
For j = pbH - 1 To 0 Step -1
  For i = 0 To tp Step 2
    t2 = PB.Point(i, j)
    For k = 0 To 15
      If fPal.Colors(k) = t2 Then Exit For
    Next k
    t2 = PB.Point(i + 1, j)
    For l = 0 To 15
      If fPal.Colors(l) = t2 Then Exit For
    Next l
    TMP = Chr$(k * 16 + l)
    Put #f, , TMP
  Next i
Next j

TMP = String$(GetLngEndIco(pbW, pbH), 0)
Put #f, , TMP

Close #f

End Sub

Sub SaveIcon16M (PB As PictureBox, pFile$)
'Cette procédure enregistre l'image PB en tant qu'icone
'en 16 millions de couleurs (24 bits) dans le fichier pFile
'PB.ScaleMode doit être à 3 - Pixel
'Les dimensions doivent être inférieures
'à 256 (c'est un icône !) et la largeur (Width) divisible par 8

'On Error Resume Next
Dim f, TMP$, tp&, pbH%, pbW%
f = FreeFile
pbH = PB.ScaleHeight
pbW = PB.ScaleWidth

VideFichier pFile
Open pFile For Binary As #f
TMP = HexaToTxt("000001000100")
Put #f, , TMP               'début du fichier
TMP = Chr$(pbW) & Chr$(pbH)
Put #f, , TMP               'dimensions
TMP = String$(6, 0)
Put #f, , TMP               'nombre_couleurs + point_actif
tp = GetLngIco(pbW, pbH, 24)
TMP = NbrToStr(tp + 40, 3) & Chr$(0)
Put #f, , TMP
TMP = Chr$(22) & String$(3, 0) & Chr$(40) & String$(3, 0)
Put #f, , TMP
TMP = Chr$(pbW) & String$(3, 0)
Put #f, , TMP
TMP = NbrToStr(pbH * 2, 2) & String$(2, 0)
Put #f, , TMP
TMP = HexaToTxt("010018") & String$(5, 0)
Put #f, , TMP
TMP = NbrToStr(tp, 3) & String$(17, 0)
Put #f, , TMP
''''''''''Fin de l'intro, ouf !'''''''''''
Dim i%, j%
tp = pbW - 1
For j = pbH - 1 To 0 Step -1
    For i = 0 To tp
    TMP = NbrToStrInv(PB.Point(i, j), 3)
    Put #f, , TMP
    Next
Next

TMP = String$(GetLngEndIco(pbW, pbH), 0)
Put #f, , TMP

Close #f

End Sub

Sub SaveIcon2 (PB As PictureBox, pFile$)
'Cette procédure enregistre l'image PB en tant qu'icone
'en 2 couleurs (1 bit) dans le fichier pFile
'PB.ScaleMode doit être à 3 - Pixel
'Les dimensions doit être divisibles par 8 et inférieures
'à 180
'Si l'icone possède :..., elle est enregistrée en :
' + de 256 couleurs       16M couleurs
' + de 16 mais - de 257   256 couleurs
' + de 2 mais - de 17     16 couleurs

'On Error Resume Next
Dim f%, TMP$, tp&, pbH%, pbW%
Dim i%, j%, k%, l%, t2&
f = FreeFile
pbH = PB.ScaleHeight
pbW = PB.ScaleWidth

Dim fPal As TYPE_PALETTE
tp = CompteCouleursPalette(PB, fPal)
Select Case tp
  Case Is > 256     '16 millions de couleurs
    SaveIcon16M PB, pFile
    Exit Sub
  Case Is > 16       '256 couleurs
    SaveIcon256 PB, pFile
    Exit Sub
  Case Is > 2      '16 couleurs
    SaveIcon16 PB, pFile
    Exit Sub
End Select

VideFichier pFile
Open pFile For Binary As #f
TMP = HexaToTxt("000001000100")
Put #f, , TMP               'début du fichier
TMP = Chr$(pbW) & Chr$(pbH) & Chr$(2)
Put #f, , TMP               'dimensions + nombre_couleurs
TMP = String$(5, 0)
Put #f, , TMP               'point_actif
tp = GetLngIco(pbW, pbH, 1)
TMP = NbrToStr(tp + 40, 3) & Chr$(0)
Put #f, , TMP
TMP = Chr$(22) & String$(3, 0) & Chr$(40) & String$(3, 0)
Put #f, , TMP
TMP = Chr$(pbW) & String$(3, 0)
Put #f, , TMP
TMP = NbrToStr(pbH * 2, 2) & String$(2, 0)
Put #f, , TMP
TMP = HexaToTxt("010001") & String$(5, 0)
Put #f, , TMP
TMP = NbrToStr(tp, 3) & String$(17, 0)
Put #f, , TMP

For i = 0 To 1    'Impression de la palette
    TMP = NbrToStrInv(fPal.Colors(i), 3) & Chr$(0)
    Put #f, , TMP
Next
''''''''''Fin de l'intro, ouf !'''''''''''
tp = pbW - 1
For j = pbH - 1 To 0 Step -1
  For i = 0 To tp Step 8
   For k = 0 To 7
    t2 = PB.Point(i + k, j)
    For l = 0 To 1
      If fPal.Colors(l) = t2 Then Exit For
    Next l
    tp = tp + l * 2 ^ k
   Next k
   TMP = Chr$(tp)
   Put #f, , TMP
  Next i
Next j

TMP = String$(GetLngEndIco(pbW, pbH), 0)
Put #f, , TMP

Close #f

End Sub

Sub SaveIcon256 (PB As PictureBox, pFile$)
'Cette procédure enregistre l'image PB en tant qu'icone
'en 256 couleurs (8 bits) dans le fichier pFile
'PB.ScaleMode doit être à 3 - Pixel
'Les dimensions doit être divisibles par 8 et inférieures
'à 180
'Si l'image comporte plus de 256 couleurs, elle est enregistrée
'en icône 16 millions de couleurs

'On Error Resume Next
Dim f%, TMP$, tp&, pbH%, pbW%
Dim i%, j%, k%, t2&
f = FreeFile
pbH = PB.ScaleHeight
pbW = PB.ScaleWidth

Dim fPal As TYPE_PALETTE
tp = CompteCouleursPalette(PB, fPal)
Select Case tp
  Case Is > 256     '16 millions de couleurs
    SaveIcon16M PB, pFile
    Exit Sub
  Case Is < 3       '2 couleurs
    SaveIcon2 PB, pFile
    Exit Sub
  Case Is < 17      '16 couleurs
    SaveIcon16 PB, pFile
    Exit Sub
End Select

VideFichier pFile
Open pFile For Binary As #f
TMP = HexaToTxt("000001000100")
Put #f, , TMP               'début du fichier
TMP = Chr$(pbW) & Chr$(pbH)
Put #f, , TMP               'dimensions
TMP = String$(6, 0)
Put #f, , TMP               'nombre_couleurs + point_actif
tp = GetLngIco(pbW, pbH, 8)
TMP = NbrToStr(tp + 40, 3) & Chr$(0)
Put #f, , TMP
TMP = Chr$(22) & String$(3, 0) & Chr$(40) & String$(3, 0)
Put #f, , TMP
TMP = Chr$(pbW) & String$(3, 0)
Put #f, , TMP
TMP = NbrToStr(pbH * 2, 2) & String$(2, 0)
Put #f, , TMP
TMP = HexaToTxt("010008") & String$(5, 0)
Put #f, , TMP
TMP = NbrToStr(tp, 3) & String$(17, 0)
Put #f, , TMP

For i = 0 To 255    'Impression de la palette
    TMP = NbrToStrInv(fPal.Colors(i), 3) & Chr$(0)
    Put #f, , TMP
Next
''''''''''Fin de l'intro, ouf !'''''''''''
tp = pbW - 1
For j = pbH - 1 To 0 Step -1
  For i = 0 To tp
    t2 = PB.Point(i, j)
    For k = 0 To 255
      If fPal.Colors(k) = t2 Then
	TMP = Chr$(k)
	Put #f, , TMP
	Exit For
      End If
    Next k
  Next i
Next j

TMP = String$(GetLngEndIco(pbW, pbH), 0)
Put #f, , TMP

Close #f

End Sub

Conclusion :


Je vais essayer de faire pour que ça prenne en compte la transparence dans la prochaine version.
Si vous ne comprenez rien, c'est pas grave... pour bien comprendre, il faut connaitre et comprendre la structure d'un fichier ICO (ou CUR, c pareil)...
Bon, j'espère que ça pourra vous aider au moins...
Merci de me dire ce que vous en pensez (commentaire et note).
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_mehdibou)