Solved

Displaying picture with modified palette

Posted on 2009-04-07
1
341 Views
Last Modified: 2012-05-06
Visual Basic 6 - I need to load a paletted bitmap (.bmp) and modify it's palette before each iteration of drawing it to my form. What is the easiest way to accomplish this? Modifying the actual file and doing a loadpicture for each iteration is too slow. Tried GetDIBits and SetDIBits with a modified palette, but it still maps my new colour values to the nearest original palette entry.
0
Comment
Question by:JasonMewes
1 Comment
 

Accepted Solution

by:
JasonMewes earned 0 total points
ID: 24094311
Managed to find a solution to the problem. The code presented is not optimal, I am sure I could do with a bit less code for loading and initialization. I am not the author of the original code, this is a subset of a class called cDIBSection256 by Steve McMahon @ vbaccelerator.com - however it has been modified enough for me to feel okay presenting it here with a reference to the original author. The code originally had a method to draw the entire loaded image, this has been changed since I am using it to display characters from an image containing a fixed-width font. It can easily be re-adapted for your own needs. Also it is no longer possible to modify the actual pixels as this was not necessary for my project, see the original cDIBSection256 for full functionality.

Summary: this code will let you load a 256 colour bitmap, edit the palette entries and then draw the picture with the modified palette to your form or otherwise (anything with a DC) allowing for quick palette cycling etc.
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(0 To 255) 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 CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (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 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 hSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pColor As Long) As Long

Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pcColor As Long) As Long

Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 Const BI_RGB = 0&

  

Private m_hDIb As Long

Private m_hBmpOld As Long

Private m_hDC As Long

Private m_lPtr As Long

Private m_tBI As BITMAPINFO

Private m_colors As Long

Private m_RGB(0 To 255) As Long

Private m_base As Long
 

Private Const m_f = 2
 

Private Function CreateDIB(ByVal lhdc As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long) As Boolean

   With m_tBI.bmiHeader

        .biSize = Len(m_tBI.bmiHeader)

        .biWidth = lWidth

        .biHeight = lHeight

        .biPlanes = 1

        .biBitCount = 8

        .biCompression = BI_RGB

        .biSizeImage = BytesPerScanLine * .biHeight

   End With

   hDib = CreateDIBSection(lhdc, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)

   CreateDIB = (hDib <> 0)

End Function
 

Public Function LoadFont(fn As String, base As Long)

    Dim lhdc As Long

    Dim lhDCDesktop As Long

    Dim lhBmpOld As Long

    Dim tBMP As BITMAP

    Dim lC As Long

    Dim picThis As StdPicture

    

    ClearUp

    

    Set picThis = LoadPicture(fn)

    m_base = base

    

    GetObjectAPI picThis.handle, Len(tBMP), tBMP

    If tBMP.bmBitsPixel = 1 Or tBMP.bmBitsPixel = 4 Or tBMP.bmBitsPixel = 8 Then

        If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then

            lhDCDesktop = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)

            If (lhDCDesktop <> 0) Then

                lhdc = CreateCompatibleDC(lhDCDesktop)

                DeleteDC lhDCDesktop

                If (lhdc <> 0) Then

                    lhBmpOld = SelectObject(lhdc, picThis.handle)

                    m_colors = 2 ^ tBMP.bmBitsPixel

                    lC = GetDIBColorTable(lhdc, 0, m_colors, m_RGB(0))

                    If lC = 0 Then

                        Debug.Print "ERROR: unable to fetch color table"

                    Else

                        GetDIBits lhdc, picThis.handle, 0, tBMP.bmHeight, ByVal m_lPtr, m_tBI, DIB_RGB_COLORS

                        SetDIBColorTable m_hDC, 0, m_colors, m_RGB(0)

                    End If

                    SelectObject lhdc, lhBmpOld

                    DeleteObject lhdc

                    If lC = 0 Then ClearUp

                End If

            End If

        End If

    Else

        Debug.Print "ERROR: tried to load non-indexed bitmap"

    End If

End Function
 

Private Function Create(ByVal lWidth As Long, ByVal lHeight As Long) As Boolean

    Dim lHDCDesk As Long

    lHDCDesk = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)

    m_hDC = CreateCompatibleDC(lHDCDesk)

    DeleteDC lHDCDesk

    If (m_hDC <> 0) Then

        If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then

            m_hBmpOld = SelectObject(m_hDC, m_hDIb)

            Create = True

        Else

            DeleteObject m_hDC

            m_hDC = 0

        End If

    End If

End Function

 

Public Sub DrawChar(hdc As Long, x As Long, y As Long, char As Byte)

    StretchBlt hdc, x * m_f, y * m_f, 8 * m_f, 8 * m_f, m_hDC, (char - m_base) * 8, 0, 8, 8, vbSrcCopy

End Sub

 

Public Sub DrawText(hdc As Long, x As Long, y As Long, text As String)

    Dim n As Long

    For n = 1 To Len(text)

        DrawChar hdc, x + (n - 1) * 8, y, Asc(Mid(text, n, 1))

    Next

End Sub

 

Public Sub ClearUp()

    If (m_hDC <> 0) Then

        If (m_hDIb <> 0) Then

            SelectObject m_hDC, m_hBmpOld

            DeleteObject m_hDIb

        End If

        DeleteObject m_hDC

    End If

    m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0

End Sub

 

Public Sub Restore()

    SetDIBColorTable m_hDC, 0, m_colors, m_RGB(0)

End Sub

 

Public Property Get Color(ByVal nIndex As Long) As Long

    Dim tColor As Long

    lC = GetDIBColorTable(m_hDC, nIndex, 1, tColor)

    Color = IIf(lC = 1, tColor, 0)

End Property
 

Public Property Let Color(ByVal nIndex As Long, ByVal lColor As Long)

   lC = SetDIBColorTable(m_hDC, nIndex, 1, lColor)

End Property
 

Private Sub Class_Terminate()

    ClearUp

End Sub

Open in new window

0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now