OleCreatePictureIndirect not want to use because I want the best quality for the icon or cursor.
this is my ugly translation, I know how some functions like memset
Code:
Option Explicit
Private Type ICONDIRENTRY
bWidth As Byte '// Width of the image
bHeight As Byte '// Height of the image (times 2)
bColorCount As Byte '// Number of colors in image (0 if >=8bpp)
bReserved As Byte '// Reserved
wPlanes As Integer '// Color Planes
wBitCount As Integer '// Bits per pixel
dwBytesInRes As Long '// how many bytes in this resource?
dwImageOffset As Long '// where in the file is this image
End Type
Private Type ICONDIR
idReserved As Integer '// Reserved
idType As Integer '// resource type (1 for icons)
idCount As Integer '// how many images?
idEntries() As ICONDIRENTRY '//array follows.
End Type
Private Type MEMICONDIRENTRY
bWidth As Byte '// Width of the image
bHeight As Byte '// Height of the image (times 2)
bColorCount As Byte '// Number of colors in image (0 if >=8bpp)
bReserved As Byte '// Reserved
wPlanes As Integer '// Color Planes
wBitCount As Integer '// Bits per pixel
dwBytesInRes As Long '// how many bytes in this resource?
nID As Integer '// the ID
End Type
Private Type BITMAPINFOHEADER ' structure used within icon image data
biSize As Long
biWidth As Long
biHeight As Long ' always doubled for icons/cursors
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 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 ICONIMAGE '<---¿?¿
icHeader As BITMAPINFOHEADER
RGBQUAD() As Byte
icXOR() As Byte
icAND() As Byte
End Type
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetIconInfo Lib "user32.dll" (ByVal hIcon As Long, ByRef piconinfo As ICONINFO) As Long
Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByRef lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32.dll" (ByRef lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByRef lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, ByRef lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Const GENERIC_WRITE As Long = &H40000000
Private Const CREATE_ALWAYS As Long = 2
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const DIB_RGB_COLORS As Long = 0
Private Const MEM_COMMIT As Long = &H1000
Private Const MEM_RELEASE As Long = &H8000
Private Const PAGE_EXECUTE_READ As Long = &H20
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const CREATE_NEW As Long = 1
Private Function NColors(ByVal bitCount As Long) As Boolean '< -- ?¿?¿?
If (bitCount = 1 Or bitCount = 4 Or bitCount = 8) Then
NColors = True
Else
If (bitCount >= 24) Then
NColors = False
End If
End If
End Function
'//---------------------------------------------------------------------------
'// Devuelve una imagen de archivo.ico para poder guardar en disco....
'// Reserva la memoria necesaria devolviendo en Size el Tamaño
'// Requiere liberar luego la memoria con VirtualFree(Mem, 0, MEM_RELEASE);
Private Function hIconToMem(hIcon As Long, BitCountPerPixel As Integer, ByRef Size As Integer) As Long
Dim hdc As Long
Dim bmpAND As BITMAP
Dim bmpXOR As BITMAP
Dim IcoInfo As ICONINFO
Dim IcoDir As ICONDIR
Dim RawDataSizeAND As Integer
Dim RawDataSizeXOR As Integer
Dim RawDataSize As Integer
Dim PalSize As Integer
Dim AllSize As Integer
Dim Width As Long, Height As Long
Dim FileIconMem As Long
Dim IcoImage As ICONIMAGE
Dim bmiAND As BITMAPINFO
Dim bmiICON As BITMAPINFO
Dim BINFOH As BITMAPINFOHEADER
Dim lpBitsXOR As Long
Dim lpBitsAND As Long
hdc = GetDC(0)
GetIconInfo hIcon, IcoInfo
Call GetObject(IcoInfo.hbmMask, LenB(bmpAND), bmpAND)
Call GetObject(IcoInfo.hbmColor, LenB(bmpXOR), bmpXOR)
If (BitCountPerPixel = 0) Then BitCountPerPixel = bmpXOR.bmPlanes * bmpXOR.bmBitsPixel
RawDataSizeAND = (((bmpAND.bmWidth + 31) And Not 31) \ 8) * bmpAND.bmHeight '((((bmpAND.bmWidth * bmpAND.bmBitsPixel) + 31) & -31) > 3) * bmpAND.bmHeight
RawDataSizeXOR = (((bmpXOR.bmWidth + 31) And Not 31) \ 8) * bmpXOR.bmHeight '((((bmpXOR.bmWidth * BitCountPerPixel) + 31) & -31) > 3) * bmpXOR.bmHeight
RawDataSize = RawDataSizeAND + RawDataSizeXOR
'PalSize=(BitCountPerPixel>8 ? 0 :1 << BitCountPerPixel)<<2; // RGBQUAD 4
AllSize = LenB(IcoDir) + LenB(BINFOH) + PalSize + RawDataSizeAND + RawDataSizeXOR
Width = bmpAND.bmWidth
Height = bmpAND.bmHeight
FileIconMem = VirtualAlloc(0, AllSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
ReDim IcoDir.idEntries(0)
With IcoDir
.idReserved = 0
.idType = 1
.idCount = 1
.idEntries(0).bWidth = Width
.idEntries(0).bHeight = Height
.idEntries(0).bColorCount = NColors(BitCountPerPixel)
.idEntries(0).bReserved = 0
.idEntries(0).wPlanes = 0 '// Color Planes
.idEntries(0).wBitCount = 0 '//BitCountPerPixel; // Bits per pixel
.idEntries(0).dwBytesInRes = AllSize - LenB(IcoDir) '// How many bytes in this resource?
.idEntries(0).dwImageOffset = LenB(IcoDir) '// Where in the file is this image?
End With
'memset(IconImage, 0, sizeof(BITMAPINFOHEADER));
With IcoImage
.icHeader.biSize = LenB(BINFOH)
.icHeader.biWidth = Width
.icHeader.biHeight = Height
.icHeader.biPlanes = 1
.icHeader.biBitCount = BitCountPerPixel
.icHeader.biSizeImage = RawDataSize
End With
'memcpy(&bmiAND, bmiICON, sizeof(BITMAPINFOHEADER));
With bmiAND
.bmiHeader.biSizeImage = RawDataSizeAND
.bmiHeader.biBitCount = 1
.bmiHeader.biClrUsed = 1
.bmiHeader.biClrImportant = 1
End With
'// Recupero los bits de cada hBitmap del icono
GetDIBits hdc, IcoInfo.hbmColor, 0, Height, lpBitsXOR, bmiICON, DIB_RGB_COLORS
GetDIBits hdc, IcoInfo.hbmMask, 0, Height, lpBitsAND, bmiAND, DIB_RGB_COLORS
IcoImage.icHeader.biHeight = Height * 2
ReleaseDC 0, hdc
Size = AllSize
hIconToMem = FileIconMem
End Function
Private Sub Form_Load()
Dim hIcon As Long
Dim Size As Integer
Dim FileIconMem As Long
Dim hFile As Long
Dim dwWritten As Long
hIcon = Me.Icon
'// Convertimos el HICON a imagen en memoria del .ico
FileIconMem = hIconToMem(hIcon, 32, Size)
hFile = CreateFile("C:\FilePath.ico", GENERIC_WRITE, FILE_SHARE_WRITE, ByVal 0&, CREATE_NEW, 0, 0)
WriteFile hFile, FileIconMem, Size, dwWritten, 0
CloseHandle hFile
Call VirtualFree(FileIconMem, 0, MEM_RELEASE)
End Sub
Here is a good routine to save icon handles to file.
1. It handles 1, 4 , 8, 16, 24 & 32 bit icons. But 16 bit are converted to 24 bit for saving.
2. Note that 32bit alpha icons will not be saved correctly unless running XP or better; nor will the hIcon display correctly anyway.
3. If successful, the passed array to the function will contain the icon in correct file format.
Too long to post, so download from attachment. Where your link tried to save all icons as 32bit & possibly 24bit, the attached code will save it as 1,4,8,24,32 bit whichever is the lowest color depth to support all the icon colors. So it is a bit more code than simply saving everything as 24 or 32 bit.
P.S. That link your provided had small memory leaks built into the routines unless Delphi cleans up the hbmColor & hbmMask bitmaps returned from GetIconInfo API.
Edited: I tweaked/commented the code so that if I wanted to use it in future projects, I could understand it in the future. To test this, start a new project, and pass an hIcon handle & target filename to the function. Either pass a Picture.Handle (if picture is an icon), or use LoadImage or other APIs to create an hIcon handle.
Last edited by LaVolpe; Jan 25th, 2010 at 02:39 PM.
Insomnia is just a byproduct of, "It can't be done"
[RESOLVED] hIcon To FileIcon (save hIcon)
Reply With Quote
