[RESOLVED] ByteArray To a PictureBox with SetDIBitsToDevice = Messed Up Colors

[Alphadan]

Hi

Wel im having this problem i have a ByteArray containing the bytes of the pixels from a image which its a 8bit image (256 Colors).

well i have the header info stored on this structure BITMAPINFO and im using this:

SetDIBitsToDevice Picture2.hdc, 0, 0, BmInfo.bmiHeader.biWidth, BmInfo.bmiHeader.biHeight, 0, 0, 0, BmInfo.bmiHeader.biHeight, PixelBArr(0), BmInfo, 0

it works fine but it has one trouble the colours get messed up it turns darker and there its a excess red

i think the picture box its configured as 24 bit color so it doesnt uses palette as i understand.

i have the right palette on a Byte Array too i ve tried for the whole day and i fail to make it work, theres a property on the picturebox hpal but kinda hard to understand.

i also tried with SetBitmapBits but the image appears like a total mess i can see some shapes from the original image but its really messed up.

Option Explicit
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObject 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 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 Long

Public 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

Public 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

Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type


Public Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type



Public Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As Long
End Type

Public Type BITMAPINFO256
  bmiHeader As BITMAPINFOHEADER
  bmiColors(255) As Long
End Type

Function SaveBitmap_AllRes(ByRef hdc As Long, ByRef handle As Long, ByRef BitsPerPixel As Byte, ByRef Barr() As Byte, BmInfo() As Byte, Optional ByRef NewPal As Variant) As Byte
On Error Resume Next
Dim bmp As Bitmap
Dim i As Integer
Dim bInfo As BITMAPINFO256
Dim FileHeader As BITMAPFILEHEADER
Dim bArray() As Byte
Dim nLines As Long
Dim WidthArray As Long
Dim Palette() As Long
Dim newP As Long
Dim nCol As Long
'Dim TempScrLen As Integer
'Dim TempScr As String
Call GetObject(handle, Len(bmp), bmp)
    
    Select Case BitsPerPixel
    Case 1, 4, 8, 16, 24, 32
        ' kein Fehler. weiter gehts!
    Case Else
        SaveBitmap_AllRes = 1
        Exit Function
    End Select
    If IsMissing(NewPal) = 0 Then
        newP = UBound(NewPal)
    End If
    bInfo.bmiHeader.biHeight = bmp.bmHeight
    bInfo.bmiHeader.biWidth = bmp.bmWidth
    bInfo.bmiHeader.biPlanes = bmp.bmPlanes
    bInfo.bmiHeader.biBitCount = BitsPerPixel
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    bInfo.bmiHeader.biCompression = 0

    nLines = GetDIBits256(hdc, handle, 0, bmp.bmHeight, ByVal 0, bInfo, DIB_RGB_COLORS)
    If nLines = 0 Then         ' Falls ein Fehler auftrat wird nLines 0,
        SaveBitmap_AllRes = 2 ' sonst ist es die Zahl der Zeilen.
        Exit Function
    End If

    WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
    ReDim bArray(WidthArray * bInfo.bmiHeader.biHeight)
    nLines = GetDIBits256(hdc, handle, 0, bmp.bmHeight, bArray(0), bInfo, DIB_RGB_COLORS)



    If nLines = 0 Then
        SaveBitmap_AllRes = 3 ' Tja, dann ist wohl was schiefgelaufen.
         Exit Function

    End If
    Select Case BitsPerPixel

    Case 1
        bInfo.bmiHeader.biClrUsed = 2
        bInfo.bmiHeader.biClrImportant = 2
        bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
        nCol = 1
    Case 4
        bInfo.bmiHeader.biClrUsed = 16
        bInfo.bmiHeader.biClrImportant = 16
        bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
        nCol = 15
    Case 8
        bInfo.bmiHeader.biClrUsed = 256
        bInfo.bmiHeader.biClrImportant = 256
        bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
        nCol = 255
    Case 16, 24, 32
        nCol = 0
    End Select

    ReDim Palette(nCol)

    If nCol > 0 Then
        If newP = nCol Then
            For i = 0 To nCol
                Palette(i) = SwapRedBlue(NewPal(i)) ' Rot und Blau sind
                ' in normalen Longs vertauscht. Wir korrigieren das hier.
            Next i
        Else
            For i = 0 To nCol
                Palette(i) = bInfo.bmiColors(i)
            Next i
        End If
    Else
        Palette(0) = 0
    End If
    
    FileHeader.bfType = 19778 ' entspricht "BM"
    FileHeader.bfOffBits = Len(FileHeader) + Len(bInfo.bmiHeader)
    FileHeader.bfOffBits = FileHeader.bfOffBits + (UBound(Palette) + 1) * 4
    FileHeader.bfSize = Len(FileHeader) + Len(bInfo.bmiHeader) + (UBound(Palette) + 1) * 4
    
    'Dim fno As Long
    'fno = FreeFile
    'Open "C:\Prueba.bmp" For Binary As #fno
    ' und wieder Ausspucken...
    'Put #fno, , FileHeader
    'Put #fno, , bInfo.bmiHeader
    'Put #fno, , Palette()
    'Put #fno, , bArray()
    'Close #fno
    
err1:
    Select Case Err
    Case 999
    SaveBitmap_AllRes = 4
    Case Else
    SaveBitmap_AllRes = 4
    End Select
End Function

this is the module im using found on net all it does its take a picture from a picturebox then it changes it BitPerPixel and saves the result to a BMP file the file opens just perfect but when it comes to input the data directly to the picturebox i get the colors messed up.

i would just save to a file and then load it using Loadpicture but it would be pretty inefficient and i need to achieve highest fps posible.

i will use anything else u can reocmend any method all what i need its to reduce the bit per pixel from a picture box from to 16B/8B/4B get the data on a byte array and then show on the same picturebox.

Thx in advance Daniel G.

[Alphadan]

Well i solved the problem using this function wich its fast i takes 1ms to load 1.7MB lenght of BMP image

ill leave the code here so it can help others

Option Explicit
Private Const GMEM_MOVEABLE = &H2
Private Declare Function GlobalAlloc Lib "kernel32" _
  (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" _
  (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
  (ByVal hMem As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" _
  Alias "RtlMoveMemory" (pDest As Any, pSource As Any, _
  ByVal dwLength As Long)
Private Declare Function CLSIDFromString Lib "ole32" _
  (ByVal lpsz As Any, pclsid As GUID) As Long
Private Declare Function OleLoadPicture Lib "olepro32" _
  (pStream As Any, ByVal lSize As Long, _
  ByVal fRunmode As CBoolean, riid As GUID, _
  ppvObj As Any) As Long
Private Type GUID    ' 16 bytes (128 bits)
  dwData1 As Long    ' 4 bytes
  wData2 As Integer  ' 2 bytes
  wData3 As Integer  ' 2 bytes
  abData4(7) As Byte ' 8 bytes, zero based
End Type
Public Enum CBoolean   ' enum members are Long data types
  CFalse = 0
  CTrue = 1
End Enum
Private Declare Function CreateStreamOnHGlobal Lib "ole32" _
  (ByVal hGlobal As Long, ByVal fDeleteOnRelease As _
  CBoolean, ppstm As Any) As Long
Private Const S_OK = 0    ' indicates successful HRESULT
Private Const sIID_IPicture = _
  "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private b1() As Byte

Private Function PictureFromBits(abPic() As Byte) _
  As IPicture  ' not a StdPicture!!
Dim nLow As Long, cbMem  As Long, hMem  As Long
Dim lpMem  As Long, IID_IPicture As GUID
Dim istm As stdole.IUnknown, ipic As IPicture
' Get the size of the picture's bits
On Error GoTo Out
nLow = LBound(abPic)
On Error GoTo 0
cbMem = (UBound(abPic) - nLow) + 1
' Allocate a global memory object
hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
If hMem Then
  ' Lock the memory object and get a pointer to it.
  lpMem = GlobalLock(hMem)
  If lpMem Then
    ' Copy the picture file bytes to the memory pointer
    ' and unlock the handle.
    MoveMemory ByVal lpMem, abPic(nLow), cbMem
    Call GlobalUnlock(hMem)
    ' Create an ISteam from the pictures bits (we can
    ' explicitly free hMem below, but we'll have the
    ' call do it here...)
    If (CreateStreamOnHGlobal(hMem, CTrue, istm) = S_OK) Then
      If (CLSIDFromString(StrPtr(sIID_IPicture), _
        IID_IPicture) = S_OK) Then
        ' Create an IPicture from the IStream (the docs
        ' say the call does not AddRef its last param, but
        'it looks like the reference counts are correct..)
        Call OleLoadPicture(ByVal ObjPtr(istm), cbMem, _
          CFalse, IID_IPicture, PictureFromBits)
      End If   ' CLSIDFromString
    End If   ' CreateStreamOnHGlobal
  End If   ' lpMem
' Call GlobalFree(hMem)
End If   ' hMem
Out:
End Function

Private Sub Command1_Click()
' Test Routine:
' First load a picture file (jpg or bmp and maybe others
' too)from a disk file into a byte array (the entire file)
' just to check that this stuff works.
Open "c:\tulips.jpg" For Binary As #1
ReDim b1(1 To LOF(1))
Get 1, , b1
Close 1
' Okay. picture is in byte array so now we can load it
' fcrom the byte array into a picture box
Picture1.Picture = PictureFromBits(b1)
End Sub