Afficher toutes les Icones d'un fichier ICO

Commenter

Contenu du snippet 

 '// 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

Compatibilité : VB6

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 (Gobillot)