procedure
ReadDIB(Stream:
Pointer
; ImageSize:
LongWord
; bmf: PBitmapFileHeader);
var
ReadPos:
cardinal
;
procedure
Read(
var
Buf;Count:
integer
);
begin
Move(
Pointer
(
Cardinal
(Stream)+ReadPos)^,Buf,Count);
inc(ReadPos,Count);
end
;
function
GetDInColors(BitCount:
Word
):
Integer
;
begin
case
BitCount
of
1
,
4
,
8
: Result :=
1
shl
BitCount;
else
Result :=
0
;
end
;
end
;
procedure
RGBTripleToQuad(
var
ColorTable);
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray =
array
[
Byte
]
of
TRGBTriple;
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray =
array
[
Byte
]
of
TRGBQuad;
var
I:
Integer
;
P3: PRGBTripleArray;
P4: PRGBQuadArray;
begin
P3 := PRGBTripleArray(@ColorTable);
P4 :=
Pointer
(P3);
for
I :=
255
downto
1
do
with
P4^[i], P3^[i]
do
begin
rgbRed := rgbtRed;
rgbGreen := rgbtGreen;
rgbBlue := rgbtBlue;
rgbReserved :=
0
;
end
;
P4^[
0
].rgbReserved :=
0
;
end
;
function
SystemPaletteOverride(
var
Pal: TMaxLogPalette):
Boolean
;
var
DC: HDC;
SysPalSize:
Integer
;
begin
Result :=
False
;
if
SystemPalette16 <>
0
then
begin
DC := GetDC(
0
);
try
SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
if
SysPalSize >=
16
then
begin
GetPaletteEntries(SystemPalette16,
0
,
8
, Pal
.
palPalEntry);
GetPaletteEntries(SystemPalette16,
8
,
8
, Pal
.
palPalEntry[Pal
.
palNumEntries -
8
]);
Result :=
True
;
end
finally
ReleaseDC(
0
,DC);
end
;
end
;
end
;
procedure
ByteSwapColors(
var
Colors; Count:
Integer
);
var
SysInfo: TSystemInfo;
begin
GetSystemInfo(SysInfo);
asm
MOV EDX, Colors
MOV ECX, Count
DEC ECX
JS @@
END
LEA EAX, SysInfo
CMP [EAX].TSystemInfo
.
wProcessorLevel,
3
JE @@
386
@@
1
: MOV EAX, [EDX+ECX*
4
]
BSWAP EAX
SHR
EAX,
8
MOV [EDX+ECX*
4
],EAX
DEC ECX
JNS @@
1
JMP @@
END
@@
386
:
PUSH EBX
@@
2
:
XOR
EBX,EBX
MOV EAX, [EDX+ECX*
4
]
MOV BH, AL
MOV BL, AH
SHR
EAX,
16
SHL
EBX,
8
MOV BL, AL
MOV [EDX+ECX*
4
],EBX
DEC ECX
JNS @@
2
POP EBX
@@
END
:
end
;
end
;
function
PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable:
Pointer
;
ColorCount:
Integer
): HPalette;
var
DC: HDC;
Save: THandle;
Pal: TMaxLogPalette;
begin
Result :=
0
;
Pal
.
palVersion :=
$300
;
if
DIBHandle <>
0
then
begin
DC := CreateCompatibleDC(
0
);
Save := SelectObject(DC, DIBHandle);
Pal
.
palNumEntries := GetDIBColorTable(DC,
0
,
256
, Pal
.
palPalEntry);
SelectObject(DC, Save);
DeleteDC(DC);
end
else
begin
Pal
.
palNumEntries := ColorCount;
Move(ColorTable^, Pal
.
palPalEntry, ColorCount *
4
);
end
;
if
Pal
.
palNumEntries =
0
then
Exit;
if
(Pal
.
palNumEntries <>
16
)
or
not
SystemPaletteOverride(Pal)
then
ByteSwapColors(Pal
.
palPalEntry, Pal
.
palNumEntries);
Result := CreatePalette(PLogPalette(@Pal)^);
end
;
const
DIBPalSizes:
array
[
Boolean
]
of
Byte
= (sizeof(TRGBQuad), sizeof(TRGBTriple));
var
DC, MemDC: HDC;
BitsMem:
Pointer
;
OS2Header: TBitmapCoreHeader;
BitmapInfo: PBitmapInfo;
ColorTable:
Pointer
;
HeaderSize:
Integer
;
OS2Format:
Boolean
;
BMHandle, OldBMP: HBITMAP;
DIB: TDIBSection;
Pal, OldPal: HPalette;
vbmf: TBitmapFileHeader;
{$IFDEF LINUX}
I:
Integer
;
{
$ENDIF
}
begin
Pal :=
0
;
BMHandle :=
0
;
ReadPos:=
0
;
Read(HeaderSize, sizeof(HeaderSize));
OS2Format := HeaderSize = sizeof(OS2Header);
if
OS2Format
then
HeaderSize := sizeof(TBitmapInfoHeader);
GetMem(BitmapInfo, HeaderSize +
12
+
256
* sizeof(TRGBQuad));
with
BitmapInfo^
do
try
try
if
OS2Format
then
begin
Read(
Pointer
(
Longint
(@OS2Header) + sizeof(HeaderSize))^,
sizeof(OS2Header) - sizeof(HeaderSize));
FillChar(bmiHeader, sizeof(bmiHeader),
0
);
with
bmiHeader, OS2Header
do
begin
biWidth := bcWidth;
biHeight := bcHeight;
biPlanes := bcPlanes;
biBitCount := bcBitCount;
end
;
Dec(ImageSize, sizeof(OS2Header));
end
else
begin
Read(
Pointer
(
Longint
(BitmapInfo) + sizeof(HeaderSize))^,
HeaderSize - sizeof(HeaderSize));
Dec(ImageSize, HeaderSize);
if
(bmiHeader
.
biCompression <> BI_BITFIELDS)
and
(bmiHeader
.
biCompression <> BI_RGB)
then
begin
if
bmf =
nil
then
begin
FillChar(vbmf, sizeof(vbmf),
0
);
vbmf
.
bfType :=
$4D42
;
vbmf
.
bfSize := ImageSize +
Cardinal
(HeaderSize);
bmf := @vbmf;
end
;
end
;
end
;
with
bmiHeader
do
begin
biSize := HeaderSize;
ColorTable :=
Pointer
(
Longint
(BitmapInfo) + HeaderSize);
if
biPlanes <>
1
then
exit;
if
(HeaderSize = sizeof(TBitmapInfoHeader))
and
((biBitCount =
16
)
or
(biBitCount =
32
))
and
(biCompression = BI_BITFIELDS)
then
begin
Read(ColorTable^,
3
* sizeof(DWORD));
Inc(
Longint
(ColorTable),
3
* sizeof(DWORD));
Dec(ImageSize,
3
* sizeof(DWORD));
end
;
if
biClrUsed =
0
then
biClrUsed := GetDInColors(biBitCount);
Read(ColorTable^, biClrUsed * DIBPalSizes[OS2Format]);
Dec(ImageSize, biClrUsed * DIBPalSizes[OS2Format]);
if
biSizeImage =
0
then
biSizeImage := BytesPerScanLine(biWidth, biBitCount,
32
) *
Abs
(biHeight);
if
biSizeImage < ImageSize
then
ImageSize := biSizeImage;
end
;
if
OS2Format
then
RGBTripleToQuad(ColorTable^);
DC := GetDC(
0
);
try
if
((bmiHeader
.
biCompression <> BI_RGB)
and
(bmiHeader
.
biCompression <> BI_BITFIELDS))
or
DDBsOnly
then
begin
MemDC :=
0
;
GetMem(BitsMem, ImageSize);
try
Read(BitsMem^, ImageSize);
MemDC := CreateCompatibleDC(DC);
OldBMP := SelectObject(MemDC, CreateCompatibleBitmap(DC,
1
,
1
));
OldPal :=
0
;
if
bmiHeader
.
biClrUsed >
0
then
begin
Pal := PaletteFromDIBColorTable(
0
, ColorTable, bmiHeader
.
biClrUsed);
OldPal := SelectPalette(MemDC, Pal,
False
);
RealizePalette(MemDC);
end
;
try
BMHandle := CreateDIBitmap(MemDC, BitmapInfo^.bmiHeader, CBM_INIT, BitsMem,
BitmapInfo^, DIB_RGB_COLORS);
if
(BMHandle =
0
)
then
if
GetLastError =
0
then
exit
else
RaiseLastOSError;
finally
if
OldPal <>
0
then
SelectPalette(MemDC, OldPal,
True
);
DeleteObject(SelectObject(MemDC, OldBMP));
end
;
finally
if
MemDC <>
0
then
DeleteDC(MemDC);
FreeMem(BitsMem);
end
;
end
else
begin
BMHandle := CreateDIBSection(DC, BitmapInfo^, DIB_RGB_COLORS, BitsMem,
0
,
0
);
if
(BMHandle =
0
)
or
(BitsMem =
nil
)
then
if
GetLastError =
0
then
exit
else
RaiseLastOSError;
try
Read(BitsMem^, ImageSize);
except
DeleteObject(BMHandle);
raise
;
end
;
end
;
finally
ReleaseDC(
0
, DC);
end
;
if
(bmiHeader
.
biBitCount >
8
)
and
(bmiHeader
.
biClrUsed >
0
)
and
(Pal =
0
)
then
Pal := PaletteFromDIBColorTable(
0
, ColorTable, bmiHeader
.
biClrUsed);
FillChar(DIB, sizeof(DIB),
0
);
GetObject(BMHandle, Sizeof(DIB), @DIB);
DIB
.
dsBmih
.
biXPelsPerMeter := bmiHeader
.
biXPelsPerMeter;
DIB
.
dsBmih
.
biYPelsPerMeter := bmiHeader
.
biYPelsPerMeter;
DIB
.
dsBmih
.
biClrUsed := bmiHeader
.
biClrUsed;
DIB
.
dsBmih
.
biClrImportant := bmiHeader
.
biClrImportant;
except
raise
;
end
;
finally
FreeMem(BitmapInfo);
end
;
end
;