如何建立256色的绘图句柄(hdc)？

Question

已有一个256色的图片文件(bmp或gif)，如何建立一个256色的内存场景(hdc)来将这个图像绘制在这个hdc中呢？我在这里搜了一下，关于这个的东西好象不少，但都有一个问题，就是这个hdc中的调色板有问题，好象是没有使用位图本身的调色板，所以绘制以后颜色有很大偏差，请问各位高手如何解决这个问题呢？
望各位高手赐教，小妹不胜感激！没多少分了，先给40吧！

Answer 1

Option ExplicitPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
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 BITMAPINFO256
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
    (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO256, _
    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 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 Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As Any) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Private Declare Function GetDIBits256 Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO256, ByVal wUsage As Long) As LongPrivate 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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Const BITMAPTYPE As Integer = &H4D42
Private Type BITMAPFILEHEADER
   bfType As Integer '- type  ="BM" i.e &H4D42 - 2
   bfSize As Long ' - size in bytes of file - 6
   bfReserved1 As Integer ' - reserved, must be 0 - 8
   bfReserved2 As Integer ' - reserved, must be 0 - 10
   bfOffBits As Long ' offset from this structure to the bitmap bits - 14
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Long, lpBI As BITMAPINFO256, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO256, ByVal wUsage As Long) As LongPrivate m_hDIb As Long
Private m_hBmpOld As Long
Private m_hDC As Long
Private m_lPtr As Long
Private m_tBI As BITMAPINFO256Private tRGB(0 To 256) As RGBQUADPrivate Function CreateFromPicture(ByRef picThis As StdPicture) As Long
    
Dim lHDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
Dim lC As Long
    
    
    
   GetObjectAPI picThis.handle, Len(tBMP), tBMP
   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)
            
            lC = GetDIBColorTable(lHDC, 0, 256, tRGB(0))
    
            GetDIBits256 lHDC, picThis.handle, 0, tBMP.bmHeight, ByVal m_lPtr, m_tBI, DIB_RGB_COLORS
    
            If (lC > 0) Then
              SetDIBColorTable m_hDC, 0, 256, tRGB(0)
            End If
    
            SelectObject lHDC, lhBmpOld
            DeleteObject lHDC
            
            CreateFromPicture = m_hDC
         End If
      End If
   End If
End FunctionPrivate 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
Private Function CreateDIB(ByVal lHDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long) As Boolean
Dim i As Long
   With m_tBI.bmiHeader
        .biSize = Len(m_tBI.bmiHeader)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 8
        .biCompression = BI_RGB
        .biSizeImage = 512 * .biHeight
   End With   hDib = CreateDIBSection(lHDC, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)
   CreateDIB = (hDib <> 0)
End Function
' 测试结果Private Sub Command1_Click()
    Dim p As StdPicture
    Dim l As Long
    Dim w As Long, h As Long
    
    
    Set p = LoadPicture("256色的图像文件.bmp或gif均可")
    w = ScaleX(p.Width, vbHimetric, vbPixels)
    h = ScaleX(p.Height, vbHimetric, vbPixels)
    
    l = CreateFromPicture(p)
    
    BitBlt Picture1.hdc, 0, 0, w, h, l, 0, 0, vbSrcCopy
End Sub大致就是这样了，没太整理，你可以再整理或优化一下。这个建立的就绝对是256色的场景了，并且使用了图版中的调色板，所以不会有失真现象