Créer un fichier ICO à partir d'une image

Commenter

Contenu du snippet 

 Const BI_RGB = 0&
 Const DIB_RGB_COLORS = 0&
 
 Private Type ICONFILEHEADER
     idReserved   As Integer
     idType       As Integer
     idCount      As Integer
 End Type
 
 Private Type ICONDIRECTORYENTRY
     bwidth          As Byte
     bheight         As Byte
     bColorCount     As Byte
     bReserved       As Byte
     wPlanes         As Integer
     wBitCount       As Integer
     dwBytesInRes    As Long
     dwImageOffset   As Long
 End Type
 
 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 BITMAPINFO
     bmiHeader    As BITMAPINFOHEADER
     bmiColors    As Long
 End Type
 
 Dim stdPic   As StdPicture
 Dim tBytes() As Byte
 
 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 Sub Lecture()
     On Error GoTo Error
     With CDial
         .InitDir = "C:\IMAGES\"
         .Filter = "Images (*.bmp;*.jpg;*.gif;*.ico;*.png)|*.bmp;*.jpg;*.gif;*.ico;*.png"
         .FilterIndex = 1
         .CancelError = True
         .Flags = cdlOFNFileMustExist
         .ShowOpen
          Set stdPic = LoadPicture(.FileName)
          End With
     Exit Sub
 Error:
     If Err = 32755 Then Exit Sub
     MsgBox Err.Description & " (" & Err & ")", vbExclamation, "Lecture Erreur"
 End Sub
 
 Private Sub Bmp2Ico(Lx As Integer, Ly As Integer, Transparence As Long)
     Dim Ifh    As ICONFILEHEADER
     Dim Ide    As ICONDIRECTORYENTRY
     Dim bih    As BITMAPINFOHEADER
     Dim Bmp    As BITMAPINFO
     Dim objPic As PictureBox
     Dim Sw     As Long
     Dim Sh     As Long
     Dim Lt     As Long
     Dim TdI    As Long
     Dim TdM    As Long
     Dim c      As Long
     Dim BwSL   As Integer
     Dim BwMK   As Integer
     Dim x      As Integer
     Dim y      As Integer
     Dim M      As Byte
     Dim Fi     As Long
     Dim Fj     As Long
     Dim Mi     As Long
     Dim Mj     As Long
     
     Sw = ScaleX(stdPic.Width, vbHimetric, vbPixels)
     Sh = ScaleX(stdPic.Height, vbHimetric, vbPixels)
  
     Set objPic = Controls.Add("VB.PictureBox", "picture")
     objPic.BorderStyle = 0
     objPic.AutoRedraw = True
     objPic.ScaleMode = 3
     objPic.Width = Lx
     objPic.Height = Ly
     objPic.PaintPicture stdPic, 0, 0, Lx, Ly, 0, 0, Sw, Sh
     objPic.Picture = objPic.Image
     Set stdPic = Nothing
 
     BwMK = ((Lx + 31) \ 32) * 4
     BwSL = Lx * 3 + (Lx Mod 4)
     TdI = CLng(Ly) * BwSL
     TdM = Ly * BwMK
     Lt = 40 + TdI + TdM
 
     ReDim tBytes(Lt + 21)
     Ifh.idType = 1
     Ifh.idCount = 1
     CopyMemory tBytes(0), Ifh, 6
     Ide.bwidth = Lx
     Ide.bheight = Ly
     Ide.bColorCount = 24
     Ide.wPlanes = 1
     Ide.wBitCount = 24
     Ide.dwBytesInRes = Lt
     Ide.dwImageOffset = 22
     CopyMemory tBytes(6), Ide, 16
     bih.biSize = 40
     bih.biWidth = Lx
     bih.biHeight = Ly + Ly
     bih.biPlanes = 1
     bih.biBitCount = 24
     bih.biSizeImage = TdI + TdM
     CopyMemory tBytes(22), bih, 40
 
     With Bmp.bmiHeader
         .biSize = 40
         .biWidth = Lx
         .biHeight = Ly
         .biPlanes = 1
         .biCompression = BI_RGB
         .biBitCount = 32
          End With
     ReDim Pix(Lx - 1, Ly - 1) As Long
     GetDIBits objPic.hdc, objPic.Picture, 0, Ly, Pix(0, 0), Bmp, DIB_RGB_COLORS
     Controls.Remove objPic
 
     Fi = 62
     Mi = 62 + TdI
     For y = 0 To Ly - 1
         Fj = Fi: Mj = Mi: M = 128
         For x = 0 To Lx - 1
             c = Pix(x, y)
             If c = Transparence Then
                c = 0
                tBytes(Mj) = tBytes(Mj) Or M
                End If
             CopyMemory tBytes(Fj), c, 3
             Fj = Fj + 3
             M = M \ 2: If M = 0 Then M = 128: Mj = Mj + 1
             Next
         Fi = Fi + BwSL: Mi = Mi + BwMK
         Next
 
 End Sub
 
 Private Sub Ecriture()
     On Error GoTo Error
     With CDial
         .Filter = "Icones(*.ico)|*.ico"
         .FilterIndex = 1
         .CancelError = True
         .Flags = cdlOFNOverwritePrompt Or cdlOFNNoReadOnlyReturn
         .ShowSave
          If Dir(.FileName) <> "" Then Kill .FileName
          Open .FileName For Binary As #1
               Put #1, , tBytes()
               Close #1
          End With
     Exit Sub
 Error:
     If Err = 32755 Then Exit Sub
     MsgBox Err.Description & " (" & Err & ")", vbExclamation, "Ecriture Erreur"
 End Sub
 
 
 '// UTILISATION:
 '// il faut un Commondialog pour la Lecture et l'Ecriture
 
 '// le traitement se déroule en 3 phases:
     Lecture
     Bmp2Ico 48, 48, &HECE9D8
     Ecriture

Compatibilité : VB6

Disponible dans d'autres langages :

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)