//================================================================== begin: DIB Codes start
{ TOleRichEdit } // DIB: device-independant bitmap
// The information to be included in RTF from a Windows
// device-independent bitmap is the concatenation of the
// BITMAPINFO structure followed by the actual pixel data.
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
Dec(Alignment);
Result:= ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
Result:= Result div 8;
end;
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
Colors: Integer);
var
DS: TDIBSection;
Bytes: Integer;
begin
DS.dsbmih.biSize := 0;
Bytes:= GetObject(Bitmap, SizeOf(DS), @DS);
if Bytes=0 then {InvalidBitmap}
else if (Bytes>=(sizeof(DS.dsbm) + sizeof(DS.dsbmih)))
and (DS.dsbmih.biSize>=DWORD(sizeof(DS.dsbmih)))
then BI:= DS.dsbmih
else begin
FillChar(BI, sizeof(BI), 0);
with BI, DS.dsbm do
begin
biSize:= SizeOf(BI);
biWidth:= bmWidth;
biHeight:= bmHeight;
end;
end;
case Colors of
2: BI.biBitCount:= 1;
3..16: begin
BI.biBitCount:= 4;
BI.biClrUsed:= Colors;
end;
17..256: begin
BI.biBitCount:= 8;
BI.biClrUsed:= Colors;
end;
else
BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
end;
BI.biPlanes:= 1;
if BI.biClrImportant>BI.biClrUsed then
BI.biClrImportant:= BI.biClrUsed;
if BI.biSizeImage=0 then
BI.biSizeImage:= BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD; Colors: Integer);
var
BI: TBitmapInfoHeader;
begin
InitializeBitmapInfoHeader(Bitmap, BI, Colors);
if BI.biBitCount>8 then
begin
InfoHeaderSize:= SizeOf(TBitmapInfoHeader);
if (BI.biCompression and BI_BITFIELDS)<>0 then Inc(InfoHeaderSize, 12);
end
else
if BI.biClrUsed=0
then InfoHeaderSize:= SizeOf(TBitmapInfoHeader)
+ SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
else InfoHeaderSize := SizeOf(TBitmapInfoHeader)
+ SizeOf(TRGBQuad) * BI.biClrUsed;
ImageSize:= BI.biSizeImage;
end;
procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD);
begin
InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
end;
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
OldPal: HPALETTE;
DC: HDC;
begin
InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
OldPal:= 0;
DC:= CreateCompatibleDC(0);
try
if Palette<>0 then
begin
OldPal:= SelectPalette(DC, Palette, False);
RealizePalette(DC);
end;
Result:= GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
TBitmapInfo(BitmapInfo), DIB_RGB_COLORS)
<>0;
finally
if OldPal<>0 then SelectPalette(DC, OldPal, False);
DeleteDC(DC);
end;
end;
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
begin
Result:= InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
end;
function BitmapToRTF(pict: TBitmap): string; // employs the above
var
bi,bb,rtf: string;
bis,bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle,bis,bbs);
SetLength(bi,bis);
SetLength(bb,bbs);
GetDIB(pict.Handle,pict.Palette,PChar(bi)^,PChar(bb)^);
rtf:= '{\rtf1{\pict\dibitmap '; // ** initiate rtf code **
SetLength(hexpict,(Length(bb) + Length(bi)) * 2);
I:= 2;
for bis:= 1 to Length(bi) do
begin
achar:= Format('%x',[Integer(bi[bis])]);
if Length(achar) = 1 then achar:= '0' + achar;
hexpict[I-1]:= achar[1];
hexpict[I]:= achar[2];
Inc(I,2);
end;
for bbs:= 1 to Length(bb) do
begin
achar:= Format('%x',[Integer(bb[bbs])]);
if Length(achar) = 1 then
achar:= '0' + achar;
hexpict[I-1]:= achar[1];
hexpict[I]:= achar[2];
Inc(I,2);
end;
rtf:= rtf + hexpict + ' }}'; // ** complete rtf code **
Result:= rtf; // ** report rtf code **
end;
//=================================================================== End: DIB codes