Attribute VB_Name = "modCopyBitmap"
Option Explicit

'       Copy Bitmap library 1.21
'  Written by Mike D Sutton of EDais
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 01/05/2004
' Last edited: 04/09/2006

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

' Version 1.21 (04/09/2006):
'   Fixed a small bug in CopyBitmap() when working from source DIB's using bit-fields compression

' Version 1.2 (18/11/2005):
'   CopyBitmap() can now convert properly to paletted bit-depths, by default it uses
'                a GDI halftone palette, but one can be specified if required.
'                Note; Default behaviour is to create halftone palette and destroy
'                      internally, so existing code will still work the same without
'                      GDI leaks.
'   CreateGreyscalePalette() - Creates a greyscale palette with between 1 and 256 levels
'
' Version 1.1 (11/07/2004):
'   CopyBitmap() now properly interprets 1-BPP DDB's and adds ability to re-depth
'   Note; Because of new optional parameter, old code may not function as expected!
'
' Version 1.0 (01/05/2004):
'   CopyBitmap() - Copies any Bitmap including conversion of type (DDB, DIB or same)
'                  and re-scaling with variable scale modes.
'------------

Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC 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 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 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 GetDesktopWindow Lib "User32.dll" () As Long
Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hWnd As Long, ByVal hDC 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 SetStretchBltMode Lib "GDI32.dll" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "GDI32.dll" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "GDI32.dll" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) 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 CreateHalftonePalette Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetPaletteEntries Lib "GDI32.dll" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, ByRef lpPaletteEntries As PaletteEntry) As Long
Private Declare Function CreatePalette Lib "GDI32.dll" (ByRef lpLogPalette As LogPalette8) As Long

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
    bmiHeader As BitmapInfoHeader
    bmiColors(255) 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 PaletteEntry
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LogPalette8
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(0 To 255) As PaletteEntry
End Type

Public Enum enCopyBMPMode
    cbmSame = &H0
    cbmDDB = &H1
    cbmDIB = &H2
End Enum

Public Enum enCopyBMPStretchMode
    cbsmBlackOnWhite = &H1
    cbsmWhiteOnBlack = &H2
    cbsmColourOnColour = &H3
    cbsmHalftone = &H4
End Enum

Public Enum enCopyBMPFlags
    cbfUseDefaultPalette = &H1  ' Use the default halftone palette rather than existing or user-specified ones
    cbfReturnPalette = &H2      ' Return HPALETTE object back to caller (in inoutPalette parameter)
    cbfDestroyUserPalette = &H4 ' Destroy the input palette after use
    cbfUseHalftoneDither = &H8  ' Use halftone dither when mapping palette (overrides stretch mode)
End Enum

Private Const DIB_RGB_COLORS As Long = &H0
Private Const BI_RGB As Long = &H0
Private Const BI_BITFIELDS As Long = &H3

Public Function CopyBitmap(ByVal inBMP As Long, _
    Optional ByVal inCopyMode As enCopyBMPMode = cbmSame, _
    Optional ByVal inNewWidth As Long = 0&, _
    Optional ByVal inNewHeight As Long = 0&, _
    Optional ByVal inNewDepth As Long = 0&, _
    Optional ByVal inStretchMode As enCopyBMPStretchMode = cbsmHalftone, _
    Optional ByRef inoutPalette As Long = 0&, _
    Optional ByVal inFlags As enCopyBMPFlags = 0&) As Long
    Dim BMInf As Bitmap
    Dim hSrcDC As Long, hSrcOldBMP As Long
    Dim hDstDC As Long, hDstBMP As Long, hDstOldBMP As Long
    Dim DIBInf As BitmapInfo
    Dim NumCol As Long
    Dim DeskWnd As Long, DeskDC As Long
    Dim UseWidth As Long, UseHeight As Long, UseDepth As Long
    Dim BlitRet As Long
    Dim hPal As Long, hOldPal As Long
    Dim Pal() As PaletteEntry, PalLen As Long
    
    ' Get some information about the source Bitmap
    If (GetObject(inBMP, Len(BMInf), BMInf) = 0) Then Exit Function
    
    Select Case inNewDepth ' Validate new depth (0 if un-defined)
        Case 0, 1, 4, 8, 16, 24, 32
        Case Else: Exit Function
    End Select
    
    ' Create some device contexts and select source Bitmap
    hSrcDC = CreateCompatibleDC(0&)
    hDstDC = CreateCompatibleDC(0&)
    hSrcOldBMP = SelectObject(hSrcDC, inBMP)
    
    ' Get size of result Bitmap
    If (inNewWidth) Then UseWidth = Abs(inNewWidth) Else UseWidth = BMInf.bmWidth
    If (inNewHeight) Then UseHeight = Abs(inNewHeight) Else UseHeight = BMInf.bmHeight
    If (inNewDepth) Then UseDepth = inNewDepth Else UseDepth = BMInf.bmBitsPixel
    
    If (hSrcOldBMP) Then ' If we're matching the format, select which the source was
        If (inCopyMode = cbmSame) Then inCopyMode = IIf(BMInf.bmBits, cbmDIB, cbmDDB)
        
        ' Converting to paletted depth, manage palette
        If (UseDepth <= 8&) Then
            If ((inoutPalette <> 0) And ((inFlags And cbfUseDefaultPalette) = 0&)) Then
                hPal = inoutPalette ' Use specified palette
            Else ' Create default halftone palette
                hPal = CreateHalftonePalette(hSrcDC)
            End If
            
            If (hPal) Then ' Get palette size
                Call GetObject(hPal, 4&, PalLen)
                
                If (PalLen > 0) Then ' Extract palette entries
                    ReDim Pal(0 To PalLen - 1) As PaletteEntry
                    Call GetPaletteEntries(hPal, 0&, PalLen - 1, Pal(0&))
                    
                    If ((inCopyMode = cbmDDB) And _
                        CBool(inFlags And cbfReturnPalette)) Then
                        ' Return the palette since DDB's require a seperate palette
                        inoutPalette = hPal
                    Else ' Destroy the HPALETTE since DIB's embed their palette
                        If ((inoutPalette = 0&) Or CBool(inFlags And cbfDestroyUserPalette)) Then _
                            Call DeleteObject(hPal)
                    End If
                End If
            End If
        End If
        
        If (inCopyMode = cbmDIB) Then ' Set DIB header size
            DIBInf.bmiHeader.biSize = Len(DIBInf.bmiHeader)
            
            ' Get DIB header information from source
            If (GetDIBits(hSrcDC, inBMP, 0&, 0&, ByVal 0&, DIBInf, DIB_RGB_COLORS)) Then
                If (((DIBInf.bmiHeader.biBitCount > 0) And _
                    (DIBInf.bmiHeader.biBitCount <= 8)) Or _
                    (DIBInf.bmiHeader.biCompression = BI_BITFIELDS)) Then
                    NumCol = DIBInf.bmiHeader.biClrUsed ' Get palette information
                    Call GetDIBits(hSrcDC, inBMP, 0&, 0&, ByVal 0&, DIBInf, DIB_RGB_COLORS)
                    DIBInf.bmiHeader.biClrUsed = NumCol
                End If
                
                With DIBInf.bmiHeader
                    ' If the bit-depth is being modified then the original bit-fields make no sense
                    If (.biBitCount <> UseDepth) Then .biCompression = BI_RGB
                    .biWidth = UseWidth
                    .biHeight = UseHeight
                    .biBitCount = UseDepth ' Fill DIB header with any new information about the size
                    .biSizeImage = ((((UseWidth * .biBitCount) + &H1F) And Not &H1F) \ &H8) * UseHeight
                End With
                
                If (hPal) Then
                    Dim LoopPal As Long
                    
                    For LoopPal = 0 To PalLen - 1
                        With Pal(LoopPal) ' Copy halftone palette into DIB palette
                            DIBInf.bmiColors(LoopPal) = RGB(.peRed, .peGreen, .peBlue)
                        End With
                    Next LoopPal
                    
                    ' Set palette length
                    DIBInf.bmiHeader.biClrUsed = PalLen
                End If
                
                ' Create new DIB with same header as source
                hDstBMP = CreateDIBSection(hDstDC, DIBInf, DIB_RGB_COLORS, 0&, 0&, 0&)
            End If
        Else
            If (BMInf.bmBitsPixel = 1) Then ' Special case 1-BPP DDB
                hDstBMP = CreateBitmap(UseWidth, UseHeight, 1&, 1&, ByVal 0&)
            Else ' Create new DDB compatible with the screen
                DeskWnd = GetDesktopWindow()
                DeskDC = GetDC(DeskWnd)
                hDstBMP = CreateCompatibleBitmap(DeskDC, UseWidth, UseHeight)
                Call ReleaseDC(DeskWnd, DeskDC)
            End If
        End If
        
        ' Select new Bitmap into destination DC
        hDstOldBMP = SelectObject(hDstDC, hDstBMP)
        
        If (hDstOldBMP) Then ' Copy source to destination
            
            ' Select the palette into the DC for DDB copies
            If ((hPal <> 0&) And (inCopyMode = cbmDDB)) Then _
                hOldPal = SelectObject(hDstDC, hPal)
            
            If ((UseWidth = BMInf.bmWidth) And (UseHeight = BMInf.bmHeight) And _
                (Not CBool(inFlags And cbfUseHalftoneDither) And (hPal <> 0))) Then ' Blit
                BlitRet = BitBlt(hDstDC, 0&, 0&, BMInf.bmWidth, _
                    BMInf.bmHeight, hSrcDC, 0&, 0&, vbSrcCopy)
            Else ' Stretch-blit
                If ((inFlags And cbfUseHalftoneDither) And (hPal <> 0)) Then
                    Call SetStretchBltMode(hDstDC, cbsmHalftone) ' Dither palette
                Else
                    Call SetStretchBltMode(hDstDC, inStretchMode)
                End If
                
                BlitRet = StretchBlt(hDstDC, 0&, 0&, UseWidth, UseHeight, _
                    hSrcDC, 0&, 0&, BMInf.bmWidth, BMInf.bmHeight, vbSrcCopy)
            End If
            
            ' De-select the palette if used
            If (hOldPal) Then Call SelectObject(hDstDC, hOldPal)
            
            If (BlitRet) Then ' Return copied Bitmap to caller
                CopyBitmap = hDstBMP
            Else ' Copy failed, destroy destination Bitmap
                Call DeleteObject(hDstBMP)
                hDstBMP = 0
            End If
            
            ' De-select destination Bitmap
            Call SelectObject(hDstDC, hDstOldBMP)
        Else ' Something went wrong
            Call DeleteObject(hDstBMP)
            hDstBMP = 0
        End If
        
        ' De-select source
        Call SelectObject(hSrcDC, hSrcOldBMP)
    End If
    
    ' Destroy surfaces
    Call DeleteDC(hDstDC)
    Call DeleteDC(hSrcDC)
End Function

Public Function CreateGreyscalePalette(ByVal inNumCols As Long) As Long ' HPALETTE
    Dim LogPal As LogPalette8
    Dim LoopPal As Long
    
    If ((inNumCols > 0) And (inNumCols <= &H100)) Then
        For LoopPal = 0 To inNumCols - 1
            With LogPal.palPalEntry(LoopPal)
                .peRed = (LoopPal * &HFF) \ (inNumCols - 1)
                .peGreen = .peRed
                .peBlue = .peRed
            End With
        Next LoopPal
        
        LogPal.palVersion = &H300
        LogPal.palNumEntries = inNumCols
        CreateGreyscalePalette = CreatePalette(LogPal)
    End If
End Function