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