How to simulate bit-fields in Delphi records? - delphi

I would like to declare a record in Delphi that contains the same layout as it has in C.
For those interested : This record is part of a union in the Windows OS's LDT_ENTRY record. (I need to use this record in Delphi because I'm working on an Xbox emulator in Delphi - see project Dxbx on sourceforge).
Anyway, the record in question is defined as:
struct
{
DWORD BaseMid : 8;
DWORD Type : 5;
DWORD Dpl : 2;
DWORD Pres : 1;
DWORD LimitHi : 4;
DWORD Sys : 1;
DWORD Reserved_0 : 1;
DWORD Default_Big : 1;
DWORD Granularity : 1;
DWORD BaseHi : 8;
}
Bits;
As far as I know, there are no bit-fields possible in Delphi. I did try this:
Bits = record
BaseMid: Byte; // 8 bits
_Type: 0..31; // 5 bits
Dpl: 0..3; // 2 bits
Pres: Boolean; // 1 bit
LimitHi: 0..15; // 4 bits
Sys: Boolean; // 1 bit
Reserved_0: Boolean; // 1 bit
Default_Big: Boolean; // 1 bit
Granularity: Boolean; // 1 bit
BaseHi: Byte; // 8 bits
end;
But alas: it's size becomes 10 bytes, instead of the expected 4.
I would like to know how I should declare the record, so that I get a record with the same layout, the same size, and the same members. Preferrably without loads of getter/setters.
TIA.

Thanks everyone!
Based on this information, I reduced this to :
RBits = record
public
BaseMid: BYTE;
private
Flags: WORD;
function GetBits(const aIndex: Integer): Integer;
procedure SetBits(const aIndex: Integer; const aValue: Integer);
public
BaseHi: BYTE;
property _Type: Integer index $0005 read GetBits write SetBits; // 5 bits at offset 0
property Dpl: Integer index $0502 read GetBits write SetBits; // 2 bits at offset 5
property Pres: Integer index $0701 read GetBits write SetBits; // 1 bit at offset 7
property LimitHi: Integer index $0804 read GetBits write SetBits; // 4 bits at offset 8
property Sys: Integer index $0C01 read GetBits write SetBits; // 1 bit at offset 12
property Reserved_0: Integer index $0D01 read GetBits write SetBits; // 1 bit at offset 13
property Default_Big: Integer index $0E01 read GetBits write SetBits; // 1 bit at offset 14
property Granularity: Integer index $0F01 read GetBits write SetBits; // 1 bit at offset 15
end;
The index is encoded as follows : (BitOffset shl 8) + NrBits. Where 1<=NrBits<=32 and 0<=BitOffset<=31
Now, I can get and set these bits as follows :
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
function RBits.GetBits(const aIndex: Integer): Integer;
var
Offset: Integer;
NrBits: Integer;
Mask: Integer;
begin
NrBits := aIndex and $FF;
Offset := aIndex shr 8;
Mask := ((1 shl NrBits) - 1);
Result := (Flags shr Offset) and Mask;
end;
procedure RBits.SetBits(const aIndex: Integer; const aValue: Integer);
var
Offset: Integer;
NrBits: Integer;
Mask: Integer;
begin
NrBits := aIndex and $FF;
Offset := aIndex shr 8;
Mask := ((1 shl NrBits) - 1);
Assert(aValue <= Mask);
Flags := (Flags and (not (Mask shl Offset))) or (aValue shl Offset);
end;
Pretty nifty, don't you think?!?!
PS: Rudy Velthuis now included a revised version of this in his excellent "Pitfalls of converting"-article.

Rudy's Delphi Corner is the best resource I know of regarding Delphi and C/C++ interoperability. His Pitfalls of conversion is pretty much a must read when using C/C++ APIs in Delphi. The chapter you'll be most interested in is Records and alignment -> Bitfields, but I urge you to read the entire thing top to bottom, twice. The other articles are definitely worth the time investment, too.

Ok, my bit manipulation is a bit rusty, so I could have reversed the bytes. But the code below gives the general idea:
type
TBits = record
private
FBaseMid : Byte;
FTypeDplPres : Byte;
FLimitHiSysEa: Byte;
FBaseHi : Byte;
function GetType: Byte;
procedure SetType(const AType: Byte);
function GetDpl: Byte;
procedure SetDbl(const ADpl: Byte);
function GetBit1(const AIndex: Integer): Boolean;
procedure SetBit1(const AIndex: Integer; const AValue: Boolean);
function GetLimitHi: Byte;
procedure SetLimitHi(const AValue: Byte);
function GetBit2(const AIndex: Integer): Boolean;
procedure SetBit2(const AIndex: Integer; const AValue: Boolean);
public
property BaseMid: Byte read FBaseMid write FBaseMid;
property &Type: Byte read GetType write SetType; // 0..31
property Dpl: Byte read GetDpl write SetDbl; // 0..3
property Pres: Boolean index 128 read GetBit1 write SetBit1;
property LimitHi: Byte read GetLimitHi write SetLimitHi; // 0..15
property Sys: Boolean index 16 read GetBit2 write SetBit2;
property Reserved0: Boolean index 32 read GetBit2 write SetBit2;
property DefaultBig: Boolean index 64 read GetBit2 write SetBit2;
property Granularity: Boolean index 128 read GetBit2 write SetBit2;
property BaseHi: Byte read FBaseHi write FBaseHi;
end;
function TBits.GetType: Byte;
begin
Result := (FTypeDplPres shr 3) and $1F;
end;
procedure TBits.SetType(const AType: Byte);
begin
FTypeDplPres := (FTypeDplPres and $07) + ((AType and $1F) shr 3);
end;
function TBits.GetDpl: Byte;
begin
Result := (FTypeDplPres and $06) shr 1;
end;
procedure TBits.SetDbl(const ADpl: Byte);
begin
FTypeDblPres := (FTypeDblPres and $F9) + ((ADpl and $3) shl 1);
end;
function TBits.GetBit1(const AIndex: Integer): Boolean;
begin
Result := FTypeDplPres and AIndex = AIndex;
end;
procedure TBits.SetBit1(const AIndex: Integer; const AValue: Boolean);
begin
if AValue then
FTypeDblPres := FTypeDblPres or AIndex
else
FTypeDblPres := FTypeDblPres and not AIndex;
end;
function TBits.GetLimitHi: Byte;
begin
Result := (FLimitHiSysEa shr 4) and $0F;
end;
procedure TBits.SetLimitHi(const AValue: Byte);
begin
FLimitHiSysEa := (FLimitHiSysEa and $0F) + ((AValue and $0F) shr 4);
end;
function TBits.GetBit2(const AIndex: Integer): Boolean;
begin
Result := FLimitHiSysEa and AIndex = AIndex;
end;
procedure TBits.SetBit2(const AIndex: Integer; const AValue: Boolean);
begin
if AValue then
FLimitHiSysEa := FLimitHiSysEa or AIndex
else
FLimitHiSysEa := FLimitHiSysEa and not AIndex;
end;

Well, you basically need to get down to the dirty with bit-manipulation.
Why, specifically, do you need to retain that structure?
If you only need to talk to a legacy program that either talks in this dialect (TCP/IP or similar), or stores data in this manner (files, etc.), then I would map a normal Delphi structure to a bit-version compatible. In other words, I would use a normally structured Delphi structure in memory, and write code to write and read that structure in a compatible manner.
If you need to save memory, I would make getters and setters that manipulate bits of internal integers or similar. This will have a performance impact, but not much more than what the original C program would have, the only difference is that the bit-manipulation would be added by compiler magic in the C version, whereas you will have to write it yourself.
If you don't have many records in memory, and don't need to talk to another program, I'd use a natural Delphi structure. Trade-off for higher performance will be more memory used.
But it all depends on your criteria.
In any case, you won't be able to talk the Delphi compiler into doing the same job for you as the C compiler.
PACKED RECORD, suggested by another here, doesn't do that, and was never meant to. It will only remove alignment padding to put integers on 32-bit boundaries and similar, but won't pack multiple fields into one byte.
Note that a common way to do this is through Delphi SETS, which are implementing internally using bit-fields. Again, you will have different code than the C variant.

Related

Writing tList<string> to tFileStream

I use Berlin in Windows 10. I try to save tList<string> to a file.
I know how to handle tStringlist, tStreamWriter and tStreamReader but I need to use tFileStream because the other type of data should be added.
In the following code the loop of Button2Click which reads the data raises an eOutOfMemory exception. When I allocate simple string value to _String it works well but if I put tList value to the same _String it seems that wrong data were written on the file. I can't understand the difference between _String := _List.List[i] and _String := 'qwert'.
How can I write tList<string> to tFileSteam?
procedure TForm1.Button1Click(Sender: TObject);
var
_List: TList<string>;
_FileStream: TFileStream;
_String: string;
i: Integer;
begin
_List := TList<string>.Create;
_List.Add('abcde');
_List.Add('abcde12345');
_FileStream := TFileStream.Create('test', fmCreate);
for i := 0 to 1 do
begin
_String := _List.List[i]; // _String := 'qwert' works well
_FileStream.Write(_string, 4);
end;
_FileStream.Free;
_List.Free;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
_FileStream: TFileStream;
_String: string;
i: Integer;
begin
_FileStream := TFileStream.Create('test', fmOpenRead);
for i := 0 to 1 do
begin
_FileStream.Read(_String, 4);
Memo1.Lines.Add(_String);
end;
_FileStream.Free;
end;
If you lookup in the docs what TFileStream.Write does, it tells you (inherited from THandleStream.Write):
function Write(const Buffer; Count: Longint): Longint; override;
function Write(const Buffer: TBytes; Offset, Count: Longint): Longint; override;
Writes Count bytes from the Buffer to the current position in the
resource.
Now, Buffer is untyped and as such is expected to be the memory address of the data to be written. You are passing a string variable which is a reference to the actual string data, the address of the variable holds a pointer to string data. You are therefore writing a pointer to the file.
To correct it pass the strings first character for the buffer, ....write(_string[1], ...
If you have compiler directive {$ZEROBASEDSTRINGS ON} you would use index 0.
Alternatively, typecast the string to PChar and dereference it: ....write(PChar(_String)^, ...
Then look at the second parameter, Count. As the docs say, it indicates the number of bytes to be written, specifically not characters. In Delphi 2009 and later strings are UnicodeString, so each character is 2 bytes. You need to pass the strings size in bytes.
This will write 4 characters (8 bytes) to the file stream:
_FileStream.Write(_String[1], 4 * SizeOf(Char));
or better
_FileStream.Write(PChar(_String)^, 4 * SizeOf(Char));
For reading you need to make corresponding changes, but most notable, you need to set the strings length before reading (length is counted in characters).
SetLength(_String, 4);
for i := 0 to 1 do
begin
_FileStream.Read(_String[1], 4 * SizeOf(Char));
Memo1.Lines.Add(_String);
end;
To continue with this low-level approach you could generalize string writing and reading as follows:
Add a variable to hold the length of a string
var
_String: string;
_Length: integer;
then writing
begin
...
for ....
begin
_String := _List.List[i];
_Length := Length(_String);
_FileStream.Write(_Length, SizeOf(Integer));
_FileStream.Write(PChar(_List.List[i])^, _Length * SizeOf(Char));
end;
and reading
begin
...
for ....
begin
_FileStream.Read(_Length, SizeOf(Integer));
SetLength(_String, _Length);
_FileStream.Read(_String[1], _Length * SizeOf(Char));
Memo1.Lines.Add(_String);
end;
IOW, you write the length first and then the string. On reading you read the length and then the string.

Dynamic array reference count in record

I have an advanced record with a dynamic array field.
The record has a class operator for concatenation of a record and a byte. Also an Add method, adding a byte.
For what I'm about to use the record, the reference count of the dynamic array field is of importance. When running the two test procedures below, you can see that the concatenation results in a reference count of 2 while the add method results in a reference count of 1.
program TestReferenceCount;
{$APPTYPE CONSOLE}
uses
System.SysUtils;
Type
TRec = record
class operator Add(const a: TRec; b: Byte): TRec;
private type
PDynArrayRec = ^TDynArrayRec;
TDynArrayRec = packed record
{$IFDEF CPUX64}
_Padding: LongInt; // Make 16 byte align for payload..
{$ENDIF}
RefCnt: LongInt;
Length: NativeInt;
end;
private
FArr: TBytes;
function GetRefCnt: Integer;
public
procedure Add(b : Byte);
property RefCnt: Integer read GetRefCnt;
end;
procedure TRec.Add(b : Byte);
var
prevLen: Integer;
begin
prevLen := System.Length(Self.FArr);
SetLength(Self.FArr, prevLen + 1);
Self.FArr[prevLen] := b;
end;
class operator TRec.Add(const a: TRec; b: Byte): TRec;
var
aLen: Integer;
begin
aLen := System.Length(a.FArr);
SetLength(Result.FArr, aLen + 1);
System.Move(a.FArr[0], Result.FArr[0], aLen);
Result.FArr[aLen] := b;
end;
function TRec.GetRefCnt: Integer;
begin
if Assigned(FArr) then
Result := PDynArrayRec(NativeInt(FArr) - SizeOf(TDynArrayRec)).RefCnt
else
Result := 0;
end;
procedure TestConcatenation;
var
r1 : TRec;
begin
WriteLn('RC:', r1.RefCnt); // <-- Writes 0
r1 := r1 + 65;
WriteLn('RC:', r1.RefCnt); // <-- Writes 2
end;
procedure TestAdd;
var
r1 : TRec;
begin
WriteLn('RC:', r1.RefCnt); // <-- Writes 0
r1.Add(65);
WriteLn('RC:', r1.RefCnt); // <-- Writes 1
end;
begin
TestConcatenation;
TestAdd;
ReadLn;
end.
The compiler takes care of the extra reference count when the record variable goes out of scope, so no problem really at this point.
But can this behavior be explained? Is it an undocumented implementation detail? Is there a way to avoid the extra count?
Let's take a look at this function:
procedure TestConcatenation;
var
r1 : TRec;
begin
r1 := r1 + 65;
end;
The compiler actually implements it like this:
procedure TestConcatenation;
var
r1 : TRec;
tmp : TRec;
begin
tmp := r1 + 65;
r1 := tmp;
end;
The compiler introduces a temporary local to store the result of r1 + 65. There's a very good reason for that. If it did not, where would it write the result of your addition operator? Since the ultimate destination is r1, if your addition operator writes directly to r1 it is modifying its input variable.
There is no way to stop the compiler generating this temporary local.

Packing and unpacking a Cardinal into four bytes

I have to pack and unpack a Cardinal into four one-byte fields (in Delphi 2010).
I'm doing this across all the pixels of a large image, so I need it to be fast!
Can anyone show me how to write these two functions? (The const and out keywords are just for clarity. If they interfere with inline assembly, then I can remove them.)
procedure FromCardinalToBytes( const aInput: Cardinal;
out aByte1: Byte;
out aByte2: Byte;
out aByte3: Byte;
out aByte4: Byte); inline;
function FromBytesToCardinal( const aByte1: Byte;
const aByte2: Byte;
const aByte3: Byte;
const aByte4: Byte):Cardinal; inline;
I'd recommed not using a function, just use a variant record.
type
TCardinalRec = packed record
case Integer of
0: (Value: Cardinal;);
1: (Bytes: array[0..3] of Byte;);
end;
Then you can easily use this to obtain the individual bytes.
var
LPixel: TCardinalRec;
...
LPixel.Value := 123455;
//Then read each of the bytes using
B1 := LPixel.Bytes[0];
B2 := LPixel.Bytes[1];
//etc.
If you absolutely must, you can put this into a function, but it's trivial enough not to bother with the overhead of a function call.
EDIT
To illustrate the efficiency of the variant record approach consider the following (assuming you're reading your image from a Stream).
var
LPixelBuffer: array[0..1023] of TCardinalRec;
...
ImageStream.Read(LPixelBuffer, SizeOf(LPixelBuffer));
for I := Low(LPixelBuffer) to High(LPixelBuffer) do
begin
//Here each byte is accessible by:
LPixelBuffer[I].Bytes[0]
LPixelBuffer[I].Bytes[1]
LPixelBuffer[I].Bytes[2]
LPixelBuffer[I].Bytes[3]
end;
PS: Instead of an arbitrarily generic Bytes array, you could explicitly name each Byte in the variant record as Red, Green, Blue, (and whatever the fourth Byte means).
There are many ways. The simplest is
function FromBytesToCardinal(const AByte1, AByte2, AByte3,
AByte4: byte): cardinal; inline;
begin
result := AByte1 + (AByte2 shl 8) + (AByte3 shl 16) + (AByte4 shl 24);
end;
procedure FromCardinalToBytes(const AInput: cardinal; out AByte1,
AByte2, AByte3, AByte4: byte); inline;
begin
AByte1 := byte(AInput);
AByte2 := byte(AInput shr 8);
AByte3 := byte(AInput shr 16);
AByte4 := byte(AInput shr 24);
end;
Slightly more sophisticated (but not necessarily faster) is
function FromBytesToCardinal2(const AByte1, AByte2, AByte3,
AByte4: byte): cardinal; inline;
begin
PByte(#result)^ := AByte1;
PByte(NativeUInt(#result) + 1)^ := AByte2;
PByte(NativeUInt(#result) + 2)^ := AByte3;
PByte(NativeUInt(#result) + 3)^ := AByte4;
end;
procedure FromCardinalToBytes2(const AInput: cardinal; out AByte1,
AByte2, AByte3, AByte4: byte); inline;
begin
AByte1 := PByte(#AInput)^;
AByte2 := PByte(NativeUInt(#AInput) + 1)^;
AByte3 := PByte(NativeUInt(#AInput) + 2)^;
AByte4 := PByte(NativeUInt(#AInput) + 3)^;
end;
If you don't need the bytes to be byte variables, you can do even trickier things, like declaring
type
PCardinalRec = ^TCardinalRec;
TCardinalRec = packed record
Byte1,
Byte2,
Byte3,
Byte4: byte;
end;
and then just cast:
var
c: cardinal;
begin
c := $12345678;
PCardinalRec(#c)^.Byte3 // get or set byte 3 in c
If you want fast you need to consider the 80x86 architecture.
The speed depends heavily on what you are doing with the bytes.
The x86 can access the bottom 2 bytes really fast, using the AL and AH registers
(least significant bytes in the 32-bit EAX register)
If you want to get at the higher order two bytes, you do not want to access those directly. Because you'll get an unaligned memory access, wasting CPU-cycles and messing up with the cache.
Making it faster
All this stuff messing with individual bytes is really not needed.
If you want to be really fast, work with 4 bytes at a time.
NewPixel:= OldPixel or $0f0f0f0f;
If you want to process your pixels really fast use inline MMX assembly and work with 8 bytes at a time.
Links:
Wikipedia: http://en.wikipedia.org/wiki/MMX_%28instruction_set%29
Explanation of the MMX instruction set: http://webster.cs.ucr.edu/AoA/Windows/HTML/TheMMXInstructionSet.html
Or re-ask your question on SO: How do I do this bitmap manipulation ... in MMX.
Really really fast
If you want it really really fast, like 100 or 1000x faster than MMX can, your videocard can do that. Google for CUDA or GPGPU.

Upgrade Indy9 to Indy10

I want to upgrade my application from Indy 9 to 10 with Delphi 2007.
In this thread there is a call to Indy9 TIdUDPBase.SendBuffer but this won't compile in Indy10 as the method parameter don't exists. The third parameter aBuffer is a var parameter and I didn't find any such method signature in Indy10.
Any alternative method to call ?
procedure TSenderThread.Execute;
var
vTimeData: TTimeDataRecord;
I: Integer;
FElapsed: Int64;
FTimerElappsed,
vLastTimerElappsed: Int64;
begin
vTimeData.Size := SizeOf(TTimeDataRecord);
vTimeData.ClientCount := 1;
Priority := tpHighest;
FIdUDPClient := TIdUDPClient.Create(nil);
FIdUDPClient.BroadcastEnabled := True;
try
while not (Terminated or Application.Terminated) do
begin
Sleep(1000);
//Measure Time frame
vLastTimerElappsed := FTimerElappsed;
QueryPerformanceCounter(FTimerElappsed);
FElapsed := ((FTimerElappsed-vLastTimerElappsed)*1000000) div FFrequency;
vTimeData.TotalTimeFrame := FElapsed;
if FRunning then
begin
FElapsed := ((FTimerElappsed-FStart)*1000000) div FFrequency;
vTimeData.CurrentMessageTime := FElapsed;
end
else
vTimeData.CurrentMessageTime := 0;
//Copy Values
vTimeData.AccumulatedTime := InterlockedExchange(TimeData.AccumulatedTime,0);
vTimeData.MessageCount := InterlockedExchange(TimeData.MessageCount,0);
for I := 0 to TimeClassMax do
vTimeData.TimeClasses[I] := InterlockedExchange(TimeData.TimeClasses[I],0);
// Calls procedure TIdUDPBase.SendBuffer(AHost: string; const APort: Integer; var ABuffer; const AByteCount: integer);
// This is changed in Indy10, unable to compile
FIdUDPClient.SendBuffer('255.255.255.255', UIPerfPort, vTimeData, TimeData.Size);
end;
finally
FreeAndNil(FIdUDPClient);
end;
end;
EDIT:
vTimeData is basically an array of integers.
TTimeDataRecord = record
Size: Integer; //Size of record structure is transfered and compared for safty reasons.
ClientCount: Integer;
AccumulatedTime: Integer; //This is the accumulated time busy in microseconds
CurrentMessageTime: Integer; //This is the time the current message has been processed. If several computers report a high value at the same time it indicates a freeze!
TotalTimeFrame: Integer; //This is the total time measured in microseconds
MessageCount: Integer;
TimeClasses: array [0..TimeClassMax] of Integer;
end;
you have a method with same name
procedure TIdUDPClient.SendBuffer(const AHost: string; const APort: TIdPort;
const ABuffer: TIdBytes);
Instead of an untyped buffer it expects an array of bytes. What is your data like? You just need to write your data as an array of bytes. Something like:
var
Buffer: TIdBytes;
begin
SetLength(Buffer, YourSizeOfData);
Move(YourData, Buffer[0], YourSizeOfData);
FIdUDPClient.SendBuffer('255.255.255.255', UIPerfPort, Buffer);
end;
But as I said it depends on the type of the data. The approach is ok however.
EDIT:
Now that I can see that you have a record you have two options:
Just move the whole record to array of bytes.
Move(#aRecord, Buffer[0], (6 + TimeClassMax) * SizeOf(Integer));
Have a CopyToBytes method in your record that does the actual copy. More general I guess.
TTimeDataRecord = record
Size: Integer; //Size of record structure is transfered and compared for safty reasons.
ClientCount: Integer;
AccumulatedTime: Integer; //This is the accumulated time busy in microseconds
CurrentMessageTime: Integer; //This is the time the current message has been processed. If several computers report a high value at the same time it indicates a freeze!
TotalTimeFrame: Integer; //This is the total time measured in microseconds
MessageCount: Integer;
TimeClasses: array [0..TimeClassMax] of Integer;
procedure CopyToBytes(var Buffer: TIdBytes);
end
Implementation of the CopyToBytes
procedure TTimeDataRecord.CopyToBytes(var Buffer: TIdBytes);
begin
// copy the data however you see fit
end;

Delphi DIB with DIB Header into TBitmap

I'm kindly asking you to help me with this problem:
There's a byte array (data: PByte) containing DIB data AND DIBHeader:
TDibHeader = record
size: Cardinal;
width: Integer;
height: Integer;
planes: Word;
bits: Word;
compression: Cardinal;
image_size: Cardinal;
x_res: Integer;
y_res: Integer;
n_colors: Cardinal;
important_colors: Cardinal;
end;
How to convert DIB to TBitmap while keeping the CPU usage low ?
I've tried http://files.codes-sources.com/fichier.aspx?id=43989&f=GdipApi.pas with no success.
I've assigned DIB to an Memory Stream:
DibMemStream.Clear;
DibMemStream.SetSize(header.image_size);
MoveMemory(DibMemStream.Memory,DibBuffer,header.image_size);
I suppose there should be DIB header written somewhere before Bitmap.LoadFromMemoryStream(DibMemStream). Not sure where.
Any ideas please ?
Thank you !
I have used the following scheme to convert in-memory images to TBitmap:
1) Fill TBMPHeader structure
TBMPHeader = packed record
bmfHeader: TBitmapFileHeader;
bmiHeader: TBitmapInfoHeader;
bmiColors: {depends on image format, may be absent};
end;
2) Write BMPHeader + Image Data to MemoryStream
3) Load TBitmap from MemoryStream using TBitmap.LoadFromStream
You seems to have bmiHeader structure filled already. Add bmfHeader and (maybe) bmiColors.
Here is the code I used to convert 256-color grayscale in-memory images to TBitmap (many years ago, sorry, so no details):
procedure TksImage.CopyToBitmap(Bitmap: TBitmap);
var
Stream: TStream;
begin
Stream:= TMemoryStream.Create;
try
SaveToStream(Stream);
Stream.Position:= 0;
Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TksImage.SaveToStream(Stream: TStream);
type
TBMPHeader = packed record
bmfHeader: TBitmapFileHeader;
bmiHeader: TBitmapInfoHeader;
bmiColors: array[0..255] of TRGBQuad;
end;
var
BMPHeader: TBMPHeader;
N: LongWord;
I: Integer;
begin
FillChar(BMPHeader, SizeOf(BMPHeader), 0);
with BMPHeader.bmfHeader do begin
bfType:= $4D42; {'BM'}
bfOffBits:= SizeOf(BMPHeader);
if FChannels = 4 then Dec(bfOffBits, SizeOf(BMPHeader.bmiColors));
bfSize:= bfOffBits + LongWord(FImageSize);
end;
with BMPHeader.bmiHeader do begin
biSize:= SizeOf(BMPHeader.bmiHeader);
biWidth:= FWidth;
biHeight:= FHeight;
biPlanes:= 1;
biBitCount:= 8 * FChannels;
biCompression:= BI_RGB;
biSizeImage:= FImageSize;
{((((biWidth * biBitCount) + 31) and not 31) shr 3) * biHeight;}
end;
N:= 0;
for I:= 0 to 255 do begin
LongWord(bmpHeader.bmiColors[I]):= N;
Inc(N, $010101);
end;
Stream.Write(BMPHeader, BMPHeader.bmfHeader.bfOffBits);
Stream.Write(FImageData^, FImageSize);
end;
It's been a long time since I did any Delphi coding and I've not been able to test this, but if you can provide a handle to the DIB, there's a function - hDIBToTBitmap1() - that should do the trick in this link:
http://www.efg2.com/Lab/Library/Delphi/Graphics/LeadToolsConversions.TXT

Resources