-
February 11th, 2009, 02:29 PM
#1
[RESOLVED] ByteArray To a PictureBox with SetDIBitsToDevice = Messed Up Colors
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:
Code:
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.
Code:
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.
Last edited by Alphadan; February 11th, 2009 at 07:10 PM.
-
February 11th, 2009, 07:09 PM
#2
Re: ByteArray To a PictureBox with SetDIBitsToDevice = Messed Up Colors
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
Code:
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
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|