Conversions

  1. HEX -> Integer
  2. Dec To HEX
  3. ASCII to HEX / math
  4. Convert binary to decimal
  5. Conversion from ICO to BMP
  6. Unix strings (Reading and Writing Unix Files)
  7. Decimals to binary

HEX -> Integer

Solution 1

From: Martin Larsson <martin.larsson@delfi-data.msmail.telemax.no>


var
  i : integer
  s : string;
begin
  s := '$' + ThatHexString;
  i := StrToInt(a);
end;

Solution 2


CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);
VAR str : String;
    Int,
    i   : integer;
BEGIN
  READLN(str);
  Int := 0;
  FOR i := 1 TO Length(str) DO
    IF str[i] < 'A' THEN Int := Int * 16 + ORD(str[i]) - 48
    ELSE Int := Int * 16 + HEX[str[i]];
  WRITELN(Int);
  READLN;
END.

Dec To HEX

From: Mark Bracey <mbracey@interaccess.com>

I guess you mean as a string, correct.


HexString := Format('%0x',DecValue);

ASCII to HEX / math

From: gregc@cryptocard.com (Greg Carter)

These work on byte array to strings, also look at the Ord and Chr functions in Delphi.

BytesToHexStr does this [0,1,1,0] of byte would be converted to string := '30313130'; HexStrToBytes goes the other way.


unit Hexstr;

interface
uses String16, SysUtils;

Type
 PByte = ^BYTE;

procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);
procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);
procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);

implementation
procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);
Const
    HexChars : Array[0..15] of Char = '0123456789ABCDEF';
var
    i, j: WORD;
begin
 SetLength(hHexStr, (InputLength * 2));
 FillChar(hHexStr, sizeof(hHexStr), #0);
 j := 1;
 for i := 1 to InputLength  do begin
    hHexStr[j] := Char(HexChars[pbyteArray^ shr  4]); inc(j);
    hHexStr[j] := Char(HexChars[pbyteArray^ and 15]); inc(j);
    inc(pbyteArray);
 end;
end;

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);
var
 i: WORD;
 c: byte;
begin
 SetLength(Response, InputLength);
 FillChar(Response, SizeOf(Response), #0);
 for i := 0 to (InputLength - 1) do begin
   c := BYTE(hexbytes[i]) And BYTE($f);
   if c > 9 then
     Inc(c, $37)
   else
     Inc(c, $30);
   Response[i + 1] := char(c);
 end;{for}
end;

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);
{pbyteArray must point to enough memory to hold the output}
var
 i, j: WORD;
 tempPtr: PChar;
 twoDigits : String[2];
begin
 tempPtr := pbyteArray;
 j := 1;
 for i := 1 to (Length(hHexStr) DIV 2) do begin
   twoDigits := Copy(hHexStr, j, 2); Inc(j, 2);
   PByte(tempPtr)^ := StrToInt('$' + twoDigits); Inc(tempPtr);
 end;{for}
end;

end.


UNIT String16.
interface
{$IFNDEF Win32}
  procedure SetLength(var S: string; Len: Integer);
  procedure SetString(var Dst: string; Src: PChar; Len: Integer);
{$ENDIF}
implementation
{$IFNDEF Win32}
  procedure SetLength(var S: string; Len: Integer);
  begin
    if Len > 255 then
      S[0] := Chr(255)
    else
      S[0] := Chr(Len)
  end;

  procedure SetString(var Dst: string; Src: PChar; Len: Integer);
  begin
    if Len > 255 then
      Move(Src^, Dst[1], 255)
    else
      Move(Src^, Dst[1], Len);
    SetLength(Dst, Len);
  end;
{$ENDIF}
end.

Convert binary to decimal

Can someone give me an idea of a simple way to convert binary (base2) to
decimal(base10).

Solution 1

[Anatoly Podgoretsky, kvk@estpak.ee]


////////////////////////////////////////////////
// convert 32 bit base2 to 32 bit base10      //
// max number = 99 999 999, return -1 if more //
////////////////////////////////////////////////

function Base10(Base2:Integer) : Integer; assembler;
asm
  cmp    eax,100000000            // check upper limit
  jb     @1                       // ok
  mov    eax,-1                   // error flag
  jmp    @exit                    // exit with -1
@1:
  push   ebx                      // save registers
  push   esi
  xor    esi,esi                  // result = 0
  mov    ebx,10                   // diveder base 10
  mov    ecx,8                    // 8 nibbles (10^8-1)
@2:
  mov    edx,0                    // clear remainder
  div    ebx                      // eax DIV 10, edx mod 10
  add    esi,edx                  // result = result + remainder[I]
  ror    esi,4                    // shift nibble
  loop	@2                       // loop for all 8 nibbles
  mov    eax,esi                  // function result
  pop    esi                      // restore registers
  pop    ebx
@exit:
end;

Solution 2

[Oliver Townshend, oliver@zip.com.au]


function IntToBin(Value: LongInt;Size: Integer): String;
var
	i: Integer;
begin
	Result:='';
	for i:=Size downto 0 do begin
	  	if Value and (1 shl i)<>0 then begin
		    	Result:=Result+'1';
		end else begin
		    	Result:=Result+'0';
		end;
	end;
end;

function BinToInt(Value: String): LongInt;
var
	i,Size: Integer;
begin
	Result:=0;
	Size:=Length(Value);
	for i:=Size downto 0 do begin
	  	if Copy(Value,i,1)='1' then begin
		    	Result:=Result+(1 shl i);
		end;
	end;
end;

Solution 3

[Demian Lessa, knowhow@compos.com.br]

Give this function any decimal value, specify a base (1..16) and it will return you a string containing the proper value, BaseX. You can use a similar method for Arabic/Roman conversion (see below).


function DecToBase( Decimal: LongInt; const Base: Byte): String;
const
  Symbols: String[16] = '0123456789ABCDEF';
var
  scratch: String;
  remainder: Byte;
begin
  scratch := '';
  repeat
    remainder := Decimal mod Base;
    scratch := Symbols[remainder + 1] + scratch;
    Decimal := Decimal div Base;
  until ( Decimal = 0 );
  Result := scratch;
end;

Give this function any decimal value (1...3999), and it will return you a string containing the proper value in Roman notation.


function DecToRoman( Decimal: LongInt ): String;
const
  Romans:  Array[1..13] of String =
    ( 'I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M' );

  Arabics: Array[1..13] of Integer = 
    ( 1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);

var 
  i: Integer;
  scratch: String;
begin
  scratch := '';
  for i := 13 downto 1 do
    while ( Decimal >= Arabics[i] ) do
    begin
      Decimal := Decimal - Arabics[i];
      scratch := scratch + Romans[i];
    end;
  Result := scratch;
end;

Conversion from ICO to BMP

Solution 1

From: vincze@ti.com (Michael Vincze)

Try:


  var
    Icon   : TIcon;
    Bitmap : TBitmap;
  begin
     Icon   := TIcon.Create;
     Bitmap := TBitmap.Create;
     Icon.LoadFromFile('c:\picture.ico');
     Bitmap.Width := Icon.Width;
     Bitmap.Height := Icon.Height;
     Bitmap.Canvas.Draw(0, 0, Icon );
     Bitmap.SaveToFile('c:\picture.bmp');
     Icon.Free;
     Bitmap.Free;
  end;

Solution 2

david sampson (dsampson@atlanta.com)

Is there an algorithm or routine to convert 32x32 bit Bitmaps to ICO's?

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms,Dialogs,ExtCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var winDC, srcdc, destdc : HDC;
    oldBitmap : HBitmap;
    iinfo : TICONINFO;
begin
    GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

    WinDC := getDC(handle);
    srcDC := CreateCompatibleDC(WinDC);
    destDC := CreateCompatibleDC(WinDC);
    oldBitmap := SelectObject(destDC, iinfo.hbmColor);
    oldBitmap := SelectObject(srcDC, iinfo.hbmMask);

    BitBlt(destdc, 0, 0, Image1.picture.icon.width,
		   Image1.picture.icon.height,
           srcdc, 0, 0, SRCPAINT);
    Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);
    DeleteDC(destDC);
    DeleteDC(srcDC);
    DeleteDC(WinDC);

	image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName)
          + 'myfile.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  image1.picture.icon.loadfromfile('c:\myicon.ico');
end;

end.

Unix strings (Reading and Writing Unix Files)

From: miano@worldnet.att.net (John M. Miano)

This is a unit that I wrote for reading and writing Unix files.
unit StreamFile;
{
        Unix Stream File Interface
        Copyright 1996 by John Miano Software
        miano@worldnet.att.net

}
interface

Uses
  SysUtils ;

Procedure AssignStreamFile (var F : Text ; Filename : String) ;

implementation

Const
  BufferSize = 128 ;

Type
  TStreamBuffer = Array [1..High (Integer)] of Char ;
  TStreamBufferPointer = ^TStreamBuffer ;

  TStreamFileRecord = Record
    Case Integer Of
      1:
        (
          Filehandle : Integer ;
          Buffer : TStreamBufferPointer ;
          BufferOffset : Integer ;
          ReadCount : Integer ;
        ) ;
      2:
        (
          Dummy : Array [1 .. 32] Of Char
        )
    End ;


Function StreamFileOpen (var F : TTextRec) : Integer ;
  Var
    Status : Integer ;
  Begin
  With TStreamFileRecord (F.UserData) Do
    Begin
    GetMem (Buffer, BufferSize) ;
    Case F.Mode Of
      fmInput:
        FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone) ;
      fmOutput:
        FileHandle := FileCreate (StrPas (F.Name)) ;
      fmInOut:
        Begin
        FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone Or 
fmOpenWrite or fmOpenRead) ;
        If FileHandle <> -1 Then
          status := FileSeek (FileHandle, 0, 2) ; { Move to end of file. }
        F.Mode := fmOutput ;
        End ;
      End ;
    BufferOffset := 0 ;
    ReadCount := 0 ;
    F.BufEnd := 0 ;  { If this is not here it thinks we are at eof. }
    If FileHandle = -1 Then
      Result := -1
    Else
      Result := 0 ;
    End ;
  End ;

Function StreamFileInOut (var F : TTextRec) : Integer ;
  Procedure Read (var Data : TStreamFileRecord) ;
    Procedure CopyData ;
      Begin
      While (F.BufEnd < Sizeof (F.Buffer) - 2)
            And (Data.BufferOffset <= Data.ReadCount)
            And (Data.Buffer [Data.BufferOffset] <> #10) Do
        Begin
        F.Buffer [F.BufEnd] := Data.Buffer^ [Data.BufferOffset] ;
        Inc (Data.BufferOffset) ;
        Inc (F.BufEnd) ;
        End ;
      If Data.Buffer [Data.BufferOffset] = #10 Then
        Begin
        F.Buffer [F.BufEnd] := #13 ;
        Inc (F.BufEnd) ;
        F.Buffer [F.BufEnd] := #10 ;
        Inc (F.BufEnd) ;
        Inc (Data.BufferOffset) ;
        End ;
      End ;

    Begin

    F.BufEnd := 0 ;
    F.BufPos := 0 ;
    F.Buffer := '' ;
    Repeat
      Begin
      If (Data.ReadCount = 0) Or (Data.BufferOffset > Data.ReadCount) Then
        Begin
        Data.BufferOffset := 1 ;
        Data.ReadCount := FileRead (Data.FileHandle, Data.Buffer^, BufferSize) 
;
        End ;
      CopyData ;
      End Until (Data.ReadCount = 0)
                Or (F.BufEnd >= Sizeof (F.Buffer) - 2) ;
    Result := 0 ;
    End ;

  Procedure Write (var Data : TStreamFileRecord) ;
    Var
      Status : Integer ;
      Destination : Integer ;
      II : Integer ;
    Begin
    With TStreamFileRecord (F.UserData) Do
      Begin
      Destination := 0 ;
      For II := 0 To F.BufPos - 1 Do
        Begin
        If F.Buffer [II] <> #13 Then
          Begin
          Inc (Destination) ;
          Buffer^[Destination] := F.Buffer [II] ;
          End ;
        End ;
      Status := FileWrite (FileHandle, Buffer^, Destination) ;
      F.BufPos := 0 ;
      Result := 0 ;
      End ;
    End ;
  Begin
  Case F.Mode Of
    fmInput:
      Read (TStreamFileRecord (F.UserData)) ;
    fmOutput:
      Write (TStreamFileRecord (F.UserData)) ;
    End ;
  End ;

Function StreamFileFlush (var F : TTextRec) : Integer ;
  Begin
  Result := 0 ;
  End ;

Function StreamFileClose (var F : TTextRec) : Integer ;
  Begin
  With TStreamFileRecord (F.UserData) Do
    Begin
    FreeMem (Buffer) ;
    FileClose (FileHandle) ;
    End ;
  Result := 0 ;
  End ;

Procedure AssignStreamFile (var F : Text ; Filename : String) ;
  Begin
  With TTextRec (F) Do
    Begin
    Mode := fmClosed ;
    BufPtr := @Buffer ;
    BufSize := Sizeof (Buffer) ;
    OpenFunc := @StreamFileOpen ;
    InOutFunc := @StreamFileInOut ;
    FlushFunc := @StreamFileFlush ;
    CloseFunc := @StreamFileClose ;
    StrPLCopy (Name, FileName, Sizeof(Name) - 1) ;
    End ;
  End ;
end.

Decimals to binary

From: cehjohnson@aol.com (CEHJohnson)

Yes, ironic that it's so difficult to find routines to convert from decimal to binary isn't it!

The following should work.(for negative numbers too)


function DecToBinStr(n: integer): string;

var
  S: string;
  i: integer;
  Negative: boolean;

begin
  if n < 0 then Negative := true;
  n := Abs(n);
  for i := 1 to SizeOf(n) * 8 do
  begin
    if n < 0 then S := S + '1' else S := S + '0';
    n := n shl 1;
  end;
  Delete(S,1,Pos('1',S) - 1);//remove leading zeros
  if Negative then S := '-' + S;
  Result := S;
end;


Please email me and tell me if you liked this page.