Funcao - hex para bin para int para roman

Top Previous Next

HEX -> Integer

--------------------------------------------------------------------------------

var

i : integer

s : string;

begin

s := '$' + ThatHexString;

i := StrToInt(a);

end;

function HexaToDecimal(Hexa:string):longint;

const

ValoresHexa : array['A'..'F'] of integer = (10,11,12,13,14,15);

var

nDecimal : longint;

nIndex : byte;

begin

nDecimal := 0;

Hexa := Uppercase(Hexa);

for nIndex := Length(Hexa) downto 1 do

if Hexa[nIndex] in ['0'..'9']

then nDecimal := nDecimal + StrToInt(Hexa[nIndex]) *

Trunc(Exp((Length(Hexa)-nIndex)*ln(16)))

else nDecimal := nDecimal + ValoresHexa[Hexa[nIndex]] *

Trunc(Exp((Length(Hexa)-nIndex)*ln(16)));

HexaToDecimal := nDecimal;

end;

--------------------------------------------------------------------------------

Dec To HEX

--------------------------------------------------------------------------------

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

--------------------------------------------------------------------------------

ASCII to HEX / math

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;

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

--------------------------------------------------------------------------------

function BinToInt(const Value: string): LongInt;

var

i,Size: Integer;

begin

Result := 0;

Size := Length(Value);

for i := (Size - 1) downto 0 do

Result := Result + Trunc(StrToInt(Copy(Value, Size - i, 1)) * Power(2,I));

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;

--------------------------------------------------------------------------------

Unix strings (Reading and Writing Unix Files)

This is a unit that I wrote for reading and writing Unix files.

--------------------------------------------------------------------------------

unit StreamFile;

{

Unix Stream File Interface

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

(

Filehandle : Integer ;

Buffer : TStreamBufferPointer ;

BufferOffset : Integer ;

ReadCount : Integer ;

) ;

(

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 ;

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 ;

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 ;

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 ;

Status := FileWrite (FileHandle, Buffer^, Destination) ;

F.BufPos := 0 ;

Result := 0 ;

End ;

Begin

Case F.Mode Of

fmInput:

Read (TStreamFileRecord (F.UserData)) ;

fmOutput:

Write (TStreamFileRecord (F.UserData)) ;

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.

--------------------------------------------------------------------------------

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;

--------------------------

function Dec_To_Base(nBase, nDec_Value, Lead_Zeros:integer; cOmit:string):string;

{Function : converts decimal integer to base n, max = Base36

Parameters : nBase = base number, ie. Hex is base 16

nDec_Value = decimal to be converted

Lead_Zeros = min number of digits if leading zeros required

cOmit = chars to omit from base (eg. I,O,U,etc)

Returns : number in base n as string}

var

Base_PChar : PChar;

Base_String : string;

To_Del, Modulus, DivNo : integer;

temp_string : string;

i, nLen, Len_Base : integer;

begin

{initialise..}

Base_String := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'; {max = Base36}

To_Del := 0;

Modulus := 0;

DivNo := nDec_Value;

result := '';

if (nBase > 36) then nBase := 36; {max = Base36}

cOmit := UpperCase(cOmit);

{build string to fit specified base}

if not(cOmit = '') then begin

{iterate thru' ommited letters}

nLen := Length(cOmit);

for i := 1 to nLen do begin

To_Del := Pos(cOmit[i], Base_String); {find position of letter}

if (To_Del > 0) then begin

{remove letter from base string}

Len_Base := Length(Base_String);

temp_string := Copy(Base_String, 0, To_Del - 1);

temp_string := temp_string + Copy(Base_String,To_Del + 1,Len_Base - To_Del);

Base_String := temp_string;

end; {if To_Del>0..}

end; {for i..}

end; {if not cOmit=''..}

{ensure string is required length for base}

SetLength(Base_String, nBase);

Base_PChar := PChar(Base_String);

{divide decimal by base & iterate until zero to convert it}

while DivNo > 0 do begin

Modulus := DivNo mod nBase; {remainder is next digit}

result := Base_PChar[Modulus] + result;

DivNo := DivNo div nBase;

end; {while..}

{fix zero value}

if (Length(result) = 0) then result := '0';

{add required leading zeros}

if (Length(result) < Lead_Zeros) then

for i := 1 to (Lead_Zeros - Length(result)) do result := '0' + result;

end; {function Dec_To_Base}

function Base_To_Dec(nBase:integer;cBase_Value, cOmit:string):integer;

{Function : converts base n integer to decimal, max = Base36

Parameters : nBase = base number, ie. Hex is base 16

cBase_Value = base n integer (as string) to be converted

cOmit = chars to omit from base (eg. I,O,U,etc)

Returns : number in decimal as string}

var

Base_PChar : PChar;

Base_String : string;

To_Del, Unit_Counter : integer;

temp_string : string;

i, nLen, Len_Base : integer;

begin

{initialise..}

Base_String := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'; {max = Base36}

To_Del := 0;

Unit_Counter := nBase;

result := 0;

if (nBase > 36) then nBase := 36; {max = Base36}

cOmit := UpperCase(cOmit);

cBase_Value := UpperCase(cBase_Value); {ensure uppercase letters}

{build string to fit specified base}

if not(cOmit = '') then begin

{iterate thru' ommited letters}

nLen := Length(cOmit);

for i := 1 to nLen do begin

To_Del := Pos(cOmit[i], Base_String); {find position of letter}

if (To_Del > 0) then begin

{remove letter from base string}

Len_Base := Length(Base_String);

temp_string := Copy(Base_String, 0, To_Del - 1);

temp_string := temp_string + Copy(Base_String,To_Del + 1,Len_Base - To_Del);

Base_String := temp_string;

end; {if To_Del>0..}

end; {for i..}

end; {if not cOmit=''..}

{ensure string is required length for base}

SetLength(Base_String, nBase);

Base_PChar := PChar(Base_String);

{iterate thru digits of base n value, each digit is a multiple of base n}

nLen := Length(cBase_Value);

if (nLen = 0) then result := 0 {fix zero value}

else begin

for i := 1 to nLen do begin

if (i = 1) then unit_counter := 1 {1st digit = units}

else if (i > 1) then unit_counter := unit_counter * nBase; {multiples of base}

result := result

+ ((Pos(Copy(cBase_Value, (Length(cBase_Value)+1)-i, 1), Base_PChar) - 1)

* unit_counter);

end; {for i:=1..}

end; {else begin..}

end; {function Base_To_Dec}