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
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.