Solved

Displaying picture with modified palette

Posted on 2009-04-07
1
362 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

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
VBA filters 2 59
How to incorporate an error traping routing to existing code in VB6 11 39
Modifying Conditional Format from VBA code 3 55
Export Data to Different .csv Files 26 103
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

808 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