Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Displaying picture with modified palette

Posted on 2009-04-07
1
Medium Priority
?
417 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

Question has a verified solution.

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

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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…
Suggested Courses

610 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