Delphi Function Library
Version 1.00
written by Gerald Holdsworth

Contains a number of useful functions for Delphi projects:

isbitset : Check to see if bit b is set in word v

setbit : Return a bit set if 'setit' is true, or 0 if not

rgbcol : Returns a TColor given r,g and b components

makeTransparent : Make a GIF transparent

PadString : Pad a string with a specified number of characters

bitmapHeader : Create a bitmap header - returns size of bitmap

validateFilename : Validate a filename

LoadDataFile : Load a file

SaveDataFile : Save a file

WriteLine : Writes a string to the TFileStream, and terminates it with 0x0A

emptyArray : Functions to empty an array of Integer or Byte

fillArray : Functions to fill an array of Integer or Byte

bit : Extract bit b from byte

GetBPP : Get the colour depth of a Bitmap

LoadBitmapFromFile : Loads an image 'filename' into TImage, if valid. Returns True if successful

Written using Borland Developer Studio 2006, and used on Embarcadero Delphi 10.1 Berlin and 10.2 Tokyo.

Code for 'Delphi Function Library':
unit Global;

interface

uses
 Vcl.Imaging.GIFImg,System.UITypes,System.Classes,Math,System.Types,Windows,
 System.SysUtils,Dialogs,ExtCtrls,Forms,StdCtrls,AdvPageControl,Controls,
 Vcl.Imaging.pngimage,Vcl.Imaging.JPEG,Vcl.Imaging.GIFImg;

type
 TByteArray    = array of Byte;
 TCharArray    = array of array[0..63,0..63] of Integer;

 function isbitset(v,b: Integer): Boolean;
 function setbit(bit: Cardinal; setit: Boolean): Cardinal;
 function rgbcol(r,g,b: Integer): TColor;
 function makeTransparent(gif: TGIFImage): TGIFImage;
 function PadString(s: String;p: Char; l: Integer): String;
 function bitmapHeader(sizex,sizey,bpp,cols: Integer; var bmp: array of Byte): Integer;
 function validateFilename(f: String): String;
 function LoadDataFile(fn: String; offset: Integer;var data: TByteArray): Integer;
 procedure SaveDataFile(fn: String; offset,length: Integer;var data: TByteArray);
 function WriteLine(var Stream: TFileStream;Line: string): boolean;
 procedure emptyArray(var a: array of Integer); overload;
 procedure emptyArray(var a: array of Byte); overload;
 procedure fillArray(var a: array of Integer); overload;
 procedure fillArray(var a: array of Byte); overload;
 function bit(byte,b: Integer): Integer;
 function GetBPP(bmp: TBitmap): Integer;
 function LoadBitmapFromFile(filename: String;var Image: TImage): Boolean;

implementation

{-------------------------------------------------------------------------------
Check to see if bit b is set in word v
-------------------------------------------------------------------------------}
function isbitset(v,b: Integer): Boolean;
var
 x: Integer;
begin
 x:=Trunc(IntPower(2,b));
 isbitset:=((v AND x)=x);
end;

{-------------------------------------------------------------------------------
Return a bit set if 'setit' is true, or 0 if not
-------------------------------------------------------------------------------}
function setbit(bit: Cardinal; setit: Boolean): Cardinal;
begin
 if setit then Result:=Trunc(IntPower(2,bit))
 else Result:=0;
end;

{-------------------------------------------------------------------------------
Returns a TColor given r,g and b components
-------------------------------------------------------------------------------}
function rgbcol(r,g,b: Integer): TColor;
begin
 r:=r AND $FF;
 g:=g AND $FF;
 b:=b AND $FF;
rgbcol:=r+
        (g shl 8)+
        (b shl 16);
end;

{-------------------------------------------------------------------------------
Make a GIF transparent
-------------------------------------------------------------------------------}
function makeTransparent(gif: TGIFImage): TGIFImage;
var
 SubImage        : TGIFFrame;
 TransparentColor: TColor;
 tridx,
 xTr,
 yTr,
 TransparentIndex: Integer;
 Ext             : TGIFGraphicControlExtension;
begin
 SubImage:=gif.Images[0];
 SubImage.ColorMap.Optimize;
 TransparentColor:=rgbcol(0,0,0);
 TransparentIndex:=-1;
 for tridx:=0 to Subimage.ColorMap.Count-1 do
 begin
  if Subimage.ColorMap.Colors[tridx]=TransparentColor then
   for yTr:=0 to Subimage.Height-1 do
   begin
    for xTr:=0 to Subimage.Width-1 do
     if Subimage.Pixels[xTr,yTr]=tridx then
     begin
      TransparentIndex:=tridx;
      Break;
     end;
    if TransparentIndex>=0 then Break;
   end;
   if TransparentIndex>=0 then Break;
 end;
 if TransparentIndex>=0 then
 begin
  Ext:=TGIFgraphicControlExtension.Create(Subimage);
  Ext.TransparentColorIndex:=TransparentIndex;
  Ext.Transparent:=True;
  Subimage.Extensions.Add(Ext);
 end;
 makeTransparent:=gif;
end;

{-------------------------------------------------------------------------------
Pad a string with a specified number of characters
-------------------------------------------------------------------------------}
function PadString(s: String;p: Char; l: Integer): String;
var
t: String;
begin
 t:=StringOfChar(p,l)+s;
 Result:=Copy(t,(Length(t)+1)-l);
end;

{-------------------------------------------------------------------------------
Create a bitmap header - returns size of bitmap
-------------------------------------------------------------------------------}
function bitmapHeader(sizex,sizey,bpp,cols: Integer; var bmp: array of Byte): Integer;
var
 rowwidth,pal,pxd,amt: Integer;
begin
 //If BPP is not supported in bitmap, change to the next highest that is
 while (bpp<>1) and (bpp<>4) and (bpp<>8) and (bpp<>16)
 and (bpp<>24) and (bpp<>32) do
  inc(bpp);
 //Work out number of colours, under 16bpp
 if bpp<16 then
  if cols=0 then
   cols:=Round(IntPower(2,bpp));
 {Work out the row width, with padding to 4 bytes}
 rowwidth:=Ceil((sizex*bpp)/32)*4;
 if bpp<16 then
  pal:=cols*4 {Size of palette - colours * 4}
 else
  pal:=0; {BPP of 16,24 and 32 do not have a palette}
 pxd:=rowwidth*sizey; {Size of pixel data}
 amt:=pxd+$36+pal;{Size of file}
 {File header}
 //0x00 2 bytes 'BM' Identifies it as a BMP
 bmp[$00]:=ord('B');
 bmp[$01]:=ord('M');
 //0x02 4 bytes Size of the file in bytes
 bmp[$02]:=  amt                    AND $FF;
 bmp[$03]:=( amt      div     $100) AND $FF;
 bmp[$04]:=( amt      div   $10000) AND $FF;
 bmp[$05]:=( amt      div $1000000) AND $FF;
 //0x06 4 bytes Reserved
 bmp[$06]:=$00;
 bmp[$07]:=$00;
 bmp[$08]:=$00;
 bmp[$09]:=$00;
 //0x0A 4 bytes Offset to pixel data
 bmp[$0A]:= ($36+pal)               AND $FF;
 bmp[$0B]:=(($36+pal) div     $100) AND $FF;
 bmp[$0C]:=(($36+pal) div   $10000) AND $FF;
 bmp[$0D]:=(($36+pal) div $1000000) AND $FF;
 {DIB Header}
 //0x0E 4 bytes Size of DIB header (0x00000028, or 40 bytes)
 bmp[$0E]:=$28;
 bmp[$0F]:=$00;
 bmp[$10]:=$00;
 bmp[$11]:=$00;
 //0x0012 4 Bitmap width
 bmp[$12]:=  sizex               AND $FF;
 bmp[$13]:=( sizex div     $100) AND $FF;
 bmp[$14]:=( sizex div   $10000) AND $FF;
 bmp[$15]:=( sizex div $1000000) AND $FF;
 //0x16 4 bytes Bitmap height
 bmp[$16]:=  sizey                  AND $FF;
 bmp[$17]:=( sizey    div     $100) AND $FF;
 bmp[$18]:=( sizey    div   $10000) AND $FF;
 bmp[$19]:=( sizey    div $1000000) AND $FF;
 //0x1A 2 bytes Colour planes (should be 0x01)
 bmp[$1A]:=$01;
 bmp[$1B]:=$00;
 //0x1C 2 bytes Colour depth/bits per pixel
 bmp[$1C]:= bpp           AND $FF;
 bmp[$1D]:=(bpp div $100) AND $FF;
 //0x1E 4 bytes Compression Method
 bmp[$1E]:=$00;
 bmp[$1F]:=$00;
 bmp[$20]:=$00;
 bmp[$21]:=$00;
 //0x22 4 bytes Size of the raw bitmap data (i.e. [0x02]-[0x0A])
 bmp[$22]:=  pxd                    AND $FF;
 bmp[$23]:=( pxd      div     $100) AND $FF;
 bmp[$24]:=( pxd      div   $10000) AND $FF;
 bmp[$25]:=( pxd      div $1000000) AND $FF;
 //0x26 4 bytes Horizontal resolution (pixel per metre)
 bmp[$26]:=$12;
 bmp[$27]:=$0B;
 bmp[$28]:=$00;
 bmp[$29]:=$00;
 //0x2A 4 bytes Vertical resolution (pixel per metre)
 bmp[$2A]:=$12;
 bmp[$2B]:=$0B;
 bmp[$2C]:=$00;
 bmp[$2D]:=$00;
 //0x2E 4 bytes Number of colours in the palette (0=2^[0x1C])
 bmp[$2E]:=  cols                   AND $FF;
 bmp[$2F]:=( cols     div     $100) AND $FF;
 bmp[$30]:=( cols     div   $10000) AND $FF;
 bmp[$31]:=( cols     div $1000000) AND $FF;
 //0x32 4 bytes Number of important colours
 bmp[$32]:=$00;
 bmp[$33]:=$00;
 bmp[$34]:=$00;
 bmp[$35]:=$00;
 //0x36 Palette data (if any)
 //Then follows raw pixel data
 Result:=amt;
end;

{-------------------------------------------------------------------------------
Validate a filename
-------------------------------------------------------------------------------}
function validateFilename(f: String): String;
var
 i: Integer;
begin
 for i:=1 to Length(f) do
  if (f[i]='\')
  or (f[i]='/')
  or (f[i]=':')
  or (f[i]='*')
  or (f[i]='?')
  or (f[i]='"')
  or (f[i]='<')
  or (f[i]='>')
  or (f[i]='|') then
   f[i]:=' ';
 Result:=f;
end;

{-------------------------------------------------------------------------------
Load a file
-------------------------------------------------------------------------------}
function LoadDataFile(fn: String; offset: Integer;var data: TByteArray): Integer;
var
 F: TFileStream;
const
 big_file = 819200; //Size of biggest file allowed
begin
 Result:=0;
 if FileExists(fn) then
 begin
  F:=TFileStream.Create(fn,fmOpenRead);
  Result:=F.Size;
  if Result+offset>big_file then
   Result:=big_file-offset;
  if Length(data)<Result+offset then
   SetLength(data,Result+offset);
  F.Position:=0;
  F.Read(data[offset],Result);
  F.Free;
 end;
end;

{-------------------------------------------------------------------------------
Save a file
-------------------------------------------------------------------------------}
procedure SaveDataFile(fn: String; offset,length: Integer;var data: TByteArray);
var
 F: TFileStream;
begin
 F:=TFileStream.Create(fn,fmCreate);
 F.Position:=0;
 F.Write(data[offset],length);
 F.Free;
end;

{-------------------------------------------------------------------------------
Writes a string to the TFileStream, and terminates it with 0x0A
-------------------------------------------------------------------------------}
function WriteLine(var Stream: TFileStream;Line: string): boolean;
var
 l,x: Integer;
 S: UTF8String;
begin
 S:=UTF8String(Line+#13#10);//PC Style is 0x0D,0x0A ; Apple style is 0x0A
 l:=Length(S);
 x:=Stream.Write(S[1],l);
 Result:=x=l;
end;

{-------------------------------------------------------------------------------
Functions to empty an array
-------------------------------------------------------------------------------}
procedure emptyArray(var a: array of Integer);
var
 x: Integer;
begin
 for x:=Low(a) to High(a) do a[x]:=0;
end;
procedure emptyArray(var a: array of Byte);
var
 x: Integer;
begin
 for x:=Low(a) to High(a) do a[x]:=0;
end;

{-------------------------------------------------------------------------------
Functions to fill an array
-------------------------------------------------------------------------------}
procedure fillArray(var a: array of Integer);
var
 x: Integer;
begin
 for x:=Low(a) to High(a) do a[x]:=x;
end;
procedure fillArray(var a: array of Byte);
var
 x: Integer;
begin
 for x:=Low(a) to High(a) do a[x]:=x;
end;

{-------------------------------------------------------------------------------
Extract bit b from byte
-------------------------------------------------------------------------------}
function bit(byte,b: Integer): Integer;
var
 r: Integer;
begin
 r:=Trunc(Power(2,b-1));
 bit:=(byte AND r) shr (b-1);
end;

{-------------------------------------------------------------------------------
Get the colour depth of a Bitmap
-------------------------------------------------------------------------------}
function GetBPP(bmp: TBitmap): Integer;
var
 buffer: array[0..1] of Byte;
 ms    : TMemoryStream;
begin
 //Create the stream
 ms:=TMemoryStream.Create;
 //Copy the bitmap into it
 ms.Position:=0;
 bmp.SaveToStream(ms);
 //Read the two bytes for the BPP
 ms.Position:=$1C;
 ms.ReadBuffer(buffer,2);
 //Turn it into a 16bit Integer
 Result:=buffer[0]+buffer[1]*$100;
 ms.Free;
end;

{-------------------------------------------------------------------------------
Loads an image 'filename' into TImage, if valid. Returns True if successful
-------------------------------------------------------------------------------}
function LoadBitmapFromFile(filename: String;var Image: TImage): Boolean;
var
 size,j    : Integer;
 pngfound,
 bmpfound,
 giffound  : Boolean;
 png       : TPNGImage;
 gif       : TGIFImage;
 buffer    : array[0..$F] of Byte;
 F         : TFileStream;
 const
  pngsig: array[0..$F] of Byte=($89,$50,$4E,$47
                               ,$0D,$0A,$1A,$0A
                               ,$00,$00,$00,$0D
                               ,$49,$48,$44,$52);
begin
 //We need to know the size of each file
 size:=0;
 //Clear the buffer
 for j:=0 to 15 do buffer[j]:=0;
 //Load each file - if file is already open, it will error
 try
  F:=TFileStream.Create(filename,fmOpenRead);
  size:=F.Size;
  F.Position:=0;
  F.Read(buffer[0],16);
  F.Free;
 except
 end;
 //Bitmaps:
 //The first two bytes should be 'BM', and the next four should be the filesize
 //which will match what we got before
 bmpfound:=(buffer[0]=ord('B')) and (buffer[1]=ord('M'))
       and (buffer[2]+buffer[3]*$100+buffer[4]*$10000+buffer[5]*$1000000=size);
 //PNG:
 //First sixteen bytes will be: 89 50 4E 47 0D 0A 1A 0A 00 00 00 0D 49 48 44 52
 pngfound:=True;
 for j:=0 to 15 do
  if buffer[j]<>pngsig[j] then pngfound:=False;
 //GIF:
 //Starts 'GIF87a' or 'GIF89a'
 giffound:=(buffer[0]=ord('G'))and(buffer[1]=ord('I'))and(buffer[2]=ord('F'))
        and(buffer[3]=ord('8'))and(buffer[5]=ord('a'))
        and((buffer[4]=ord('7'))or(buffer[4]=ord('9')));
 //If we have found one of the above, then load it
 try
  if (bmpfound) or (pngfound) or (giffound) then
  begin
   if bmpfound then
    Image.Picture.Bitmap.LoadFromFile(filename);
   if pngfound then
   begin
    png:=TPNGImage.Create;
    png.LoadFromFile(filename);
    Image.Picture.Bitmap.Width:=png.Width;
    Image.Picture.Bitmap.Height:=png.Height;
    Image.Canvas.Draw(0,0,png);
    png.Free;
   end;
   if giffound then
   begin
    gif:=TGIFImage.Create;
    gif.LoadFromFile(filename);
    Image.Picture.Bitmap.Width:=gif.Width;
    Image.Picture.Bitmap.Height:=gif.Height;
    Image.Canvas.Draw(0,0,gif);
    gif.Free;
   end;
  end;
 except
  bmpfound:=False;
  pngfound:=False;
  giffound:=False;
 end;
 Result:=bmpfound or pngfound or giffound;
end;

end.
Click here to download.

If you would like to email me, put gerald@ in front of the domain name, insead of www..
©2011-2020 Gerald Holdsworth IT Services