[RESOLVED] hIcon To FileIcon (save hIcon)

hello, I was trying to save a hicon, but my attempt was a failure.
as a reference this link in Delphi, but failed to translate correctly.
http://www.clubdelphi.com/trucos/index.php?id=575

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.

Thank you very much, was just what I was looking for.

Greetings.