Attribute VB_Name = "modIconHelper"
Option Explicit

'       Icon helper library 1.2
'  Written by Mike D Sutton of EDais
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 01/05/2004
' Last edited: 11/07/2004
'
' Dependencies (All available on the EDais site):
'   modChromaBlt.bas
'   modCopyBitmap.bas

'Version history:
'----------------

' Version 1.2 (11/07/2004):
'   CopyIcon() - Copies an HICON and allows for re-scaling and conversion of Bitmap types
'
' Version 1.1 (04/05/2004):
'   IconToBitmap() - Converts an HICON to a HBITMAP with a specified background colour
'
' Version 1.0 (01/05/2004):
'   BitmapToIcon() - Converts a HBITMAP to an HICON with a specified transparent colour
'------------

Private Declare Function CreateIconIndirect Lib "User32.dll" (ByRef pIconInfo As IconInfo) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As Long) 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 CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function SetTextColor Lib "GDI32.dll" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "GDI32.dll" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "GDI32.dll" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetIconInfo Lib "User32.dll" (ByVal hIcon As Long, ByRef pIconInfo As IconInfo) As Long
Private Declare Function CreateDIBSection Lib "GDI32.dll" (ByVal hDC As Long, ByRef pBitmapInfo As BitmapInfo, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw 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 DrawIconEx Lib "User32.dll" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function FillRect Lib "User32.dll" (ByVal hDC As Long, ByRef lpRect As RectAPI, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "GDI32.dll" (ByVal crColor As Long) As Long
Private Declare Function SetRect Lib "User32.dll" (ByRef lpRect As RectAPI, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Type IconInfo
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type Bitmap ' 24 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Type BitmapInfoHeader ' 40 bytes
    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 ' 1064 bytes
    bmiHeader As BitmapInfoHeader
    bmiColors(255) As Long
End Type

Private Type RectAPI
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const DI_NORMAL As Long = &H3
Private Const BI_BITFIELDS As Long = &H3

' Take a HBITMAP and return an HICON
Public Function BitmapToIcon(ByVal inBMP As Long, _
    Optional ByVal inTransCol As Long = vbBlack) As Long
    Dim IconInf As IconInfo
    Dim BMInf As Bitmap
    Dim hSrcDC As Long, hSrcBMP As Long, hSrcOldBMP As Long
    Dim hMaskDC As Long, hMaskBMP As Long, hMaskOldBMP As Long
    
    ' Get some information about this Bitmap and create a mask the same size
    If (GetObject(inBMP, Len(BMInf), BMInf) = 0) Then Exit Function
    
    ' Create a copy of the original Bitmap as a DDB that we can play with
    hSrcBMP = CopyBitmap(inBMP, cbmDDB)
    
    ' Create DC's and select source copy
    hSrcDC = CreateCompatibleDC(0)
    hMaskDC = CreateCompatibleDC(0)
    hSrcOldBMP = SelectObject(hSrcDC, hSrcBMP)
    
    If (hSrcOldBMP) Then ' Extract a colour mask from source copy
        hMaskBMP = GetColMask(hSrcDC, 0, 0, BMInf.bmWidth, BMInf.bmHeight, inTransCol)
        hMaskOldBMP = SelectObject(hMaskDC, hMaskBMP)
        
        If (hMaskOldBMP) Then ' Overlay inverted mask over source
            Call SetTextColor(hSrcDC, vbWhite)
            Call SetBkColor(hSrcDC, vbBlack)
            Call BitBlt(hSrcDC, 0, 0, BMInf.bmWidth, BMInf.bmHeight, hMaskDC, 0, 0, vbSrcAnd)
            Call SelectObject(hMaskDC, hMaskOldBMP) ' De-select mask
        End If
        
        ' De-select source copy
        Call SelectObject(hSrcDC, hSrcOldBMP)
    End If
    
    ' Destroy DC's
    Call DeleteDC(hMaskDC)
    Call DeleteDC(hSrcDC)
    
    With IconInf ' Set some information about the icon
        .fIcon = True
        .hbmMask = hMaskBMP
        .hbmColor = hSrcBMP
    End With
    
    ' Create the icon and destroy the temp mask
    BitmapToIcon = CreateIconIndirect(IconInf)
    
    ' Destroy interim Bitmaps
    Call DeleteObject(hMaskBMP)
    Call DeleteObject(hSrcBMP)
End Function

' Take an HICON and return a HBITMAP
Public Function IconToBitmap(ByVal inIcon As Long, _
    Optional ByVal inTransCol As Long = vbMagenta) As Long
    Dim IconInf As IconInfo
    Dim BMInf As Bitmap
    Dim TempDC As Long
    Dim RetBMP As Long, OldBMP As Long
    Dim BMHead As BitmapInfo
    Dim ClrUsed As Long
    Dim MaxCols As Long
    Dim LoopPal As Long
    Dim RetVal As Long
    Dim FillArea As RectAPI
    Dim FillBrush As Long
    
    If (GetIconInfo(inIcon, IconInf) = 0) Then Exit Function ' Not an icon
    Call GetObject(IconInf.hbmMask, Len(BMInf), BMInf) ' Get information about the mask Bitmap
    
    ' Create a temporary DC
    TempDC = CreateCompatibleDC(0)
    
    ' Set Bitmap header structure size
    BMHead.bmiHeader.biSize = Len(BMHead.bmiHeader)
    
    ' For 1-BPP icons, both the XOR and AND images are stored in the Mask bitmap
    If ((IconInf.hbmColor = 0) And (BMInf.bmBitsPixel = 1)) Then
        With BMHead.bmiHeader ' Fill bitmap header structure manually
            .biWidth = BMInf.bmWidth
            .biHeight = BMInf.bmHeight \ 2
            .biPlanes = 1
            
            If ((inTransCol = vbWhite) Or (inTransCol = vbBlack)) Then
                .biBitCount = 1 ' Transparent colour is already in the palette
                .biClrUsed = 2
            Else ' Need to bump the bit-depth up to the next valid level
                 ' since the image will now have three colours in the palette
                .biBitCount = 4
                .biClrUsed = 3
                BMHead.bmiColors(2) = inTransCol
            End If
        End With
        
        ' Set default mask colours
        BMHead.bmiColors(0) = vbBlack
        BMHead.bmiColors(1) = vbWhite
    Else ' Retrieve bitmap header information from colour Bitmap
        Call GetDIBits(TempDC, IconInf.hbmColor, 0, 0, ByVal 0&, BMHead, 0)
        
        ' Paletted images require a bit more work...
        If (BMHead.bmiHeader.biBitCount <= 8) Then
            With BMHead.bmiHeader ' We'll be using this structure a lot..
                ClrUsed = .biClrUsed ' Buffer used colour count and extract palette
                Call GetDIBits(TempDC, IconInf.hbmColor, 0, 0, ByVal 0&, BMHead, 0)
                .biClrUsed = ClrUsed ' Re-set old used colour count
                
                ' Get the maximum number of colours allowed in the palette for this bit-depth
                MaxCols = 2 ^ .biBitCount
                
                ' Validate colour used count
                If ((.biClrUsed <= 0) Or (.biClrUsed > MaxCols)) Then .biClrUsed = MaxCols
                
                ' Loop through current palette looking for transparent colour
                For LoopPal = 0 To .biClrUsed - 1
                    If (BMHead.bmiColors(LoopPal) = inTransCol) Then Exit For
                Next LoopPal
                
                If (LoopPal = .biClrUsed) Then ' Transparent colour not found in palette
                    If (.biClrUsed = MaxCols) Then ' The current palette is full
                        Select Case .biBitCount
                            Case 1 ' Bump up to 4-bit and add transparent colour
                                BMHead.bmiColors(2) = inTransCol
                                .biClrUsed = MaxCols + 1
                                .biBitCount = 4
                            Case 4 ' Bump up to 8-bit and add transparent colour
                                BMHead.bmiColors(&H10) = inTransCol
                                .biClrUsed = MaxCols + 1
                                .biBitCount = 8
                            Case 8 ' Bump up to 24-bit and ditch palette (16-bit is the next logical depth,
                                   '  but may not be able to display all of the colours in an 8-bit image)
                                .biBitCount = 24
                                .biClrImportant = 0
                                .biClrUsed = 0
                        End Select
                        
                        .biSizeImage = 0
                    Else ' Space left in palette, add colour and increment colour used count
                        BMHead.bmiColors(.biClrUsed) = inTransCol
                        .biClrUsed = .biClrUsed + 1
                    End If
                End If
            End With
        ElseIf (BMHead.bmiHeader.biCompression = BI_BITFIELDS) Then  ' Retrieve bit-field colour masks
            Call GetDIBits(TempDC, IconInf.hbmColor, 0, 0, ByVal 0&, BMHead, 0)
        End If
    End If
    
    ' Create output DIBSection, select into temporary DC and draw icon to it
    RetBMP = CreateDIBSection(TempDC, BMHead, 0, 0, 0, 0)
    If (RetBMP) Then
        OldBMP = SelectObject(TempDC, RetBMP)
        
        If (OldBMP) Then ' Fill background with transparent colour
            Call SetRect(FillArea, 0, 0, BMHead.bmiHeader.biWidth, BMHead.bmiHeader.biHeight)
            FillBrush = CreateSolidBrush(inTransCol)
            Call FillRect(TempDC, FillArea, FillBrush)
            Call DeleteObject(FillBrush)
            
            ' Draw icon over background
            RetVal = DrawIconEx(TempDC, 0, 0, inIcon, BMHead.bmiHeader.biWidth, _
                BMHead.bmiHeader.biHeight, 0, False, DI_NORMAL)
            Call SelectObject(TempDC, OldBMP)
        End If
    End If
    
    Call DeleteDC(TempDC)
    
    ' This icon drawing fails, we'll abort returning the Bitmap
    If (RetVal = 0) Then
        Call DeleteObject(RetBMP)
    Else ' Set output DIB as return
        IconToBitmap = RetBMP
    End If
    
    ' Destroy temporary Bitmaps
    Call DeleteObject(IconInf.hbmColor)
    Call DeleteObject(IconInf.hbmMask)
End Function

Public Function CopyIcon(ByVal inIcon As Long, _
    Optional ByVal inWidth As Long = 0, _
    Optional ByVal inHeight As Long = 0, _
    Optional ByVal inCopyMode As enCopyBMPMode = cbmSame) As Long
    Dim IconInf As IconInfo
    Dim BigColour As Long, BigMask As Long
    Dim BMColour As Bitmap, BMMask As Bitmap
    Dim UseWidth As Long, UseHeight As Long
    
    If (GetIconInfo(inIcon, IconInf)) Then ' Grab source icon information
        Call GetObject(IconInf.hbmMask, Len(BMMask), BMMask)
        
        ' Get new scale for icon
        UseHeight = IIf(inHeight, Abs(inHeight), BMMask.bmHeight)
        UseWidth = IIf(inWidth, Abs(inWidth), BMMask.bmWidth)
        
        ' Only uses mask Bitmap - Height is doubled
        If (IconInf.hbmColor = 0) Then UseHeight = UseHeight * 2
        
        ' Re-scale mask Bitmap and destroy original
        BigMask = CopyBitmap(IconInf.hbmMask, inCopyMode, _
            UseWidth, UseHeight, 0, cbsmColourOnColour)
        Call DeleteObject(IconInf.hbmMask)
        
        If (IconInf.hbmColor) Then
            ' Only some icons have colour bitmaps so re-scale only when required
            Call GetObject(IconInf.hbmColor, Len(BMColour), BMColour)
            BigColour = CopyBitmap(IconInf.hbmColor, inCopyMode, _
                UseWidth, UseHeight, 0, cbsmColourOnColour)
            Call DeleteObject(IconInf.hbmColor)
        End If
        
        ' Put new Bitmaps back into icon info structure, and scale hotspot (For cursors)
        IconInf.hbmMask = BigMask
        IconInf.hbmColor = BigColour
        IconInf.xHotspot = (IconInf.xHotspot / BMMask.bmWidth) * UseWidth
        IconInf.yHotspot = (IconInf.yHotspot / BMMask.bmHeight) * UseHeight
        
        ' Create new API icon
        CopyIcon = CreateIconIndirect(IconInf)
        
        ' Delete new Bitmaps - System uses copies
        Call DeleteObject(BigColour)
        Call DeleteObject(BigMask)
    End If
End Function