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

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;

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.

JPEG and bitmaps in Delphi 3

From: David Irizarry <xerxees@ix.netcom.com>

> >Using Delphi 3, how do I translate a bitmap into an JPEG file? > Assume Image1 is a TImage component containing a bitmap. You could use the following code segment to convert the bitmap into a JPEG file format:

var
  MyJpeg: TJpegImage;
  Image1: TImage;
begin
  Image1:= TImage.Create;
  MyJpeg:= TJpegImage.Create;
  Image1.LoadFromFile('TestImage.BMP');  // Load the Bitmap from a file
  MyJpeg.Assign(Image1.Picture.Bitmap);  // Assign the BitMap to MyJpeg
object
  MyJpeg.SaveToFile('MyJPEGImage.JPG'); // Save the JPEG to Disk
end;

Convert Wave format file to Raw data format

Does any body know how to convert a wave format file to raw format. e.g.
I want to strip out any header or encoding mechanism/method  which may be
stored or encode in a wave file.

I have a D1/D2 routine that reads WAV files and pulls out raw data, but it doesn't decompress using the various forms of compression.

unit LinearSystem;

interface

{============== WAV Format Coding Type ==================}
type WAVHeader = record
                  nChannels       : Word;
                  nBitsPerSample  : LongInt;
                  nSamplesPerSec  : LongInt;
                  nAvgBytesPerSec : LongInt;
                  RIFFSize        : LongInt;
                  fmtSize         : LongInt;
                  formatTag       : Word;
                  nBlockAlign     : LongInt;
                  DataSize        : LongInt;
                 end;

{============== Sample DataStreams ========================}
const MaxN = 300;  { max number of sample values }
type  SampleIndex = 0 .. MaxN+3;
type  DataStream = array[ SampleIndex ] of Real;

var   N     : SampleIndex;

{============== Observation Variables ======================}
type  Observation = record
                       Name       : String[40]; {Name of this observation}
                       yyy        : DataStream; {Array of data points}
                       WAV        : WAVHeader;  {WAV specs for observation}
                       Last       : SampleIndex;{Last valid index to yyy}
                       MinO, MaxO : Real;       {Range values from yyy}
                    end;

var   K0R, K1R, K2R, K3R : Observation;
      K0B, K1B, K2B, K3B : Observation;

{================== File Name Variables  ===================}
var   StandardDatabase : String[ 80 ];
      BaseFileName     : String[ 80 ];
      StandardOutput   : String[ 80 ];
      StandardInput    : String[ 80 ];

{=============== Operations ==================}
procedure ReadWAVFile (var Ki, Kj : Observation);
procedure WriteWAVFile(var Ki, Kj : Observation);
procedure ScaleData   (var Kk     : Observation);
procedure InitAllSignals;
procedure InitLinearSystem;


implementation
{$R *.DFM}
uses VarGraph, SysUtils;

{================== Standard WAV File Format  ===================}
const MaxDataSize : LongInt = (MaxN+1)*2*2;
const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36;
const StandardWAV : WAVHeader = (
                  nChannels       : Word(2);
                  nBitsPerSample  : LongInt(16);
                  nSamplesPerSec  : LongInt(8000);
                  nAvgBytesPerSec : LongInt(32000);
                  RIFFSize        : LongInt((MaxN+1)*2*2+36);
                  fmtSize         : LongInt(16);
                  formatTag       : Word(1);
                  nBlockAlign     : LongInt(4);
                  DataSize        : LongInt((MaxN+1)*2*2)
                                );


{================== Scale Observation Data  ===================}

procedure ScaleData(var Kk : Observation);
var I : SampleIndex;
begin
    {Initialize the scale values}
    Kk.MaxO := Kk.yyy[0];
    Kk.MinO := Kk.yyy[0];

    {Then scan for any higher or lower values}
    for I := 1 to Kk.Last do
         begin
            if Kk.MaxO < Kk.yyy[I] then Kk.MaxO := Kk.yyy[I];
            if Kk.MinO > Kk.yyy[I] then Kk.MinO := Kk.yyy[I];
         end;
end; { ScaleData }

procedure ScaleAllData;
begin
   ScaleData(K0R);
   ScaleData(K0B);
   ScaleData(K1R);
   ScaleData(K1B);
   ScaleData(K2R);
   ScaleData(K2B);
   ScaleData(K3R);
   ScaleData(K3B);
end; {ScaleAllData}

{================== WAV Data I/O ===================}

VAR InFile, OutFile : file of Byte;

type Tag = (F0, T1, M1);
type FudgeNum = record
                case X:Tag of
                  F0 : (chrs : array[0..3] of Byte);
                  T1 : (lint : LongInt);
                  M1 : (up,dn: Integer);
                end;
var ChunkSize  : FudgeNum;

procedure WriteChunkName(Name:String);
var i  : Integer;
    MM : Byte;
begin
   for i := 1 to 4 do
   begin
      MM := ord(Name[i]);
      write(OutFile,MM);
   end;
end; {WriteChunkName}

procedure WriteChunkSize(LL:Longint);
var I : integer;
begin
   ChunkSize.x:=T1;
   ChunkSize.lint:=LL;
   ChunkSize.x:=F0;
   for I := 0 to 3 do Write(OutFile,ChunkSize.chrs[I]);
end;

procedure WriteChunkWord(WW:Word);
var I : integer;
begin
   ChunkSize.x:=T1;
   ChunkSize.up:=WW;
   ChunkSize.x:=M1;
   for I := 0 to 1 do Write(OutFile,ChunkSize.chrs[I]);
end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj : Observation);
var I : Integer;
begin
   ChunkSize.x:=M1;
   with Ki.WAV do
   begin
      case nChannels of
       1:if nBitsPerSample=16
         then begin {1..2 16-bit samples in buffer for one channel}
                    ChunkSize.up := trunc(Ki.yyy[N]+0.5);
                    if N<MaxN then ChunkSize.dn := trunc(Ki.yyy[N+1]+0.5);
                    N := N+2;
              end
         else begin {1..4 8-bit samples in buffer for one channel}
                    for I:=0 to 3 do ChunkSize.chrs[I]
                                     := trunc(Ki.yyy[N+I]+0.5);
                    N := N+4;
              end;
       2:if nBitsPerSample=16
         then begin {2 16-bit samples on two channels}
                    ChunkSize.dn := trunc(Ki.yyy[N]+0.5);
                    ChunkSize.up := trunc(Kj.yyy[N]+0.5);
                    N := N+1;
              end
         else begin {4 8-bit samples on two channels}
                    ChunkSize.chrs[1] := trunc(Ki.yyy[N]+0.5);
                    ChunkSize.chrs[3] := trunc(Ki.yyy[N+1]+0.5);
                    ChunkSize.chrs[0] := trunc(Kj.yyy[N]+0.5);
                    ChunkSize.chrs[2] := trunc(Kj.yyy[N+1]+0.5);
                    N := N+2;
              end;
      end; {with WAV do begin..}
   end; {the four-byte variable "ChunkSize" has now been filled}

   ChunkSize.x:=T1;
   WriteChunkSize(ChunkSize.lint);{put 4 bytes of data}
end; {WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj : Observation);
var MM          : Byte;
    I           : Integer;
    OK          : Boolean;
begin
    {Prepare to write a file of data}
     AssignFile(OutFile, StandardOutput); { File selected in dialog }
     ReWrite( OutFile );
     With Ki.WAV do
     begin DataSize := nChannels*(nBitsPerSample div 8)*(Ki.Last+1);
           RIFFSize := DataSize+36;
           fmtSize  := 16;
     end;

    {Write ChunkName "RIFF"}
     WriteChunkName('RIFF');

    {Write ChunkSize}
     WriteChunkSize(Ki.WAV.RIFFSize);

    {Write ChunkName "WAVE"}
     WriteChunkName('WAVE');

    {Write tag "fmt_"}
     WriteChunkName('fmt ');

    {Write ChunkSize}
     Ki.WAV.fmtSize := 16;  {should be 16-18}
     WriteChunkSize(Ki.WAV.fmtSize);

    {Write  formatTag, nChannels}
     WriteChunkWord(Ki.WAV.formatTag);
     WriteChunkWord(Ki.WAV.nChannels);

    {Write  nSamplesPerSec}
     WriteChunkSize(Ki.WAV.nSamplesPerSec);

    {Write  nAvgBytesPerSec}
     WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

    {Write  nBlockAlign, nBitsPerSample}
     WriteChunkWord(Ki.WAV.nBlockAlign);
     WriteChunkWord(Ki.WAV.nBitsPerSample);

     {WriteDataBlock tag "data"}
     WriteChunkName('data');

     {Write DataSize}
     WriteChunkSize(Ki.WAV.DataSize);

     N:=0; {first write-out location}
     while N<=Ki.Last do WriteOneDataBlock(Ki,Kj); {put 4 bytes & increment N}

    {Free the file buffers}
     CloseFile( OutFile );
end; {WriteWAVFile}

procedure InitSpecs;
begin
end; { InitSpecs }

procedure InitSignals(var Kk : Observation);
var J : Integer;
begin
   for J := 0 to MaxN do Kk.yyy[J] := 0.0;
   Kk.MinO := 0.0;
   Kk.MaxO := 0.0;
   Kk.Last := MaxN;
end; {InitSignals}

procedure InitAllSignals;
begin
   InitSignals(K0R);
   InitSignals(K0B);
   InitSignals(K1R);
   InitSignals(K1B);
   InitSignals(K2R);
   InitSignals(K2B);
   InitSignals(K3R);
   InitSignals(K3B);
end; {InitAllSignals}

var ChunkName  : string[4];

procedure ReadChunkName;
var I  : integer;
    MM : Byte;
begin
     ChunkName[0]:=chr(4);
     for I := 1 to 4 do
     begin
        Read(InFile,MM);
        ChunkName[I]:=chr(MM);
     end;
end; {ReadChunkName}

procedure ReadChunkSize;
var I  : integer;
    MM : Byte;
begin
     ChunkSize.x := F0;
     ChunkSize.lint := 0;
     for I := 0 to 3 do
     begin
        Read(InFile,MM);
        ChunkSize.chrs[I]:=MM;
     end;
     ChunkSize.x := T1;
end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki,Kj:Observation);
var I : Integer;
begin
   if N<=MaxN then
   begin
      ReadChunkSize; {get 4 bytes of data}
      ChunkSize.x:=M1;
      with Ki.WAV do
      case nChannels of
       1:if nBitsPerSample=16
         then begin {1..2 16-bit samples in buffer for one channel}
                    Ki.yyy[N]  :=1.0*ChunkSize.up;
                    if N<MaxN then Ki.yyy[N+1]:=1.0*ChunkSize.dn;
                    N := N+2;
              end
         else begin {1..4 8-bit samples in buffer for one channel}
                    for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I];
                    N := N+4;
              end;
       2:if nBitsPerSample=16
         then begin {2 16-bit samples on two channels}
                    Ki.yyy[N]:=1.0*ChunkSize.dn;
                    Kj.yyy[N]:=1.0*ChunkSize.up;
                    N := N+1;
              end
         else begin {4 8-bit samples on two channels}
                    Ki.yyy[N]  :=1.0*ChunkSize.chrs[1];
                    Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];
                    Kj.yyy[N]  :=1.0*ChunkSize.chrs[0];
                    Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];
                    N := N+2;
              end;
      end;
      if N<=MaxN then begin {LastN    := N;}
                            Ki.Last := N;
                            if Ki.WAV.nChannels=2 then Kj.Last := N;
                      end
                 else begin {LastN    := MaxN;}
                            Ki.Last := MaxN;
                            if Ki.WAV.nChannels=2 then Kj.Last := MaxN;
                      end;
   end;
end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, Kj :Observation);
var MM          : Byte;
    I           : Integer;
    OK          : Boolean;
    NoDataYet   : Boolean;
    DataYet     : Boolean;
    nDataBytes  : LongInt;
begin
  if FileExists(StandardInput)
  then
     with Ki.WAV do
     begin  { Bring up open file dialog }
     OK := True; {unless changed somewhere below}
    {Prepare to read a file of data}
     AssignFile(InFile, StandardInput); { File selected in dialog }
     Reset( InFile );

    {Read ChunkName "RIFF"}
     ReadChunkName;
     if ChunkName<>'RIFF' then OK := False;

    {Read ChunkSize}
     ReadChunkSize;
     RIFFSize    := ChunkSize.lint; {should be 18,678}

    {Read ChunkName "WAVE"}
     ReadChunkName;
     if ChunkName<>'WAVE' then OK := False;

    {Read ChunkName "fmt_"}
     ReadChunkName;
     if ChunkName<>'fmt ' then OK := False;

    {Read ChunkSize}
     ReadChunkSize;
     fmtSize     := ChunkSize.lint;  {should be 18}

    {Read  formatTag, nChannels}
     ReadChunkSize;
     ChunkSize.x := M1;
     formatTag   := ChunkSize.up;
     nChannels   := ChunkSize.dn;

    {Read  nSamplesPerSec}
     ReadChunkSize;
     nSamplesPerSec  := ChunkSize.lint;

    {Read  nAvgBytesPerSec}
     ReadChunkSize;
     nAvgBytesPerSec := ChunkSize.lint;

    {Read  nBlockAlign}
     ChunkSize.x := F0;
     ChunkSize.lint := 0;
     for I := 0 to 3 do
     begin Read(InFile,MM);
           ChunkSize.chrs[I]:=MM;
     end;
     ChunkSize.x := M1;
     nBlockAlign := ChunkSize.up;

    {Read  nBitsPerSample}
     nBitsPerSample := ChunkSize.dn;
     for I := 17 to fmtSize do Read(InFile,MM);

     NoDataYet := True;
     while NoDataYet do
     begin
       {Read tag "data"}
        ReadChunkName;

       {Read  DataSize}
        ReadChunkSize;
        DataSize := ChunkSize.lint;

        if ChunkName<>'data' then
        begin
           for I := 1 to DataSize do {skip over any nondata stuff}
                             Read(InFile,MM);
        end
        else NoDataYet := False;
     end;

     nDataBytes := DataSize;
    {Finally, start reading data for nDataBytes bytes}
     if nDataBytes>0 then DataYet := True;
     N:=0; {first read-in location}
     while DataYet do
     begin
        ReadOneDataBlock(Ki,Kj); {get 4 bytes}
        nDataBytes := nDataBytes-4;
        if nDataBytes<=4 then DataYet := False;
     end;

    ScaleData(Ki);
    if Ki.WAV.nChannels=2
    then begin Kj.WAV := Ki.WAV;
               ScaleData(Kj);
         end;
    {Free the file buffers}
     CloseFile( InFile );
  end
  else begin
          InitSpecs;{file does not exist}
          InitSignals(Ki);{zero "Ki" array}
          InitSignals(Kj);{zero "Kj" array}
       end;
end; { ReadWAVFile }



{================= Database Operations ====================}

const MaxNumberOfDataBaseItems = 360;
type  SignalDirectoryIndex = 0 .. MaxNumberOfDataBaseItems;

VAR DataBaseFile     : file of Observation;
    LastDataBaseItem : LongInt; {Current number of database items}
    ItemNameS : array[SignalDirectoryIndex] of String[40];

procedure GetDatabaseItem( Kk : Observation; N : LongInt );
begin
   if N<=LastDataBaseItem
   then begin
           Seek(DataBaseFile, N);
           Read(DataBaseFile, Kk);
        end
   else InitSignals(Kk);
end; {GetDatabaseItem}

procedure PutDatabaseItem( Kk : Observation; N : LongInt );
begin
 if N<MaxNumberOfDataBaseItems
 then
   if N<=LastDataBaseItem
   then begin
           Seek(DataBaseFile,  N);
           Write(DataBaseFile, Kk);
           LastDataBaseItem := LastDataBaseItem+1;
        end
   else while LastDataBaseItem<=N do
        begin
           Seek(DataBaseFile,  LastDataBaseItem);
           Write(DataBaseFile, Kk);
           LastDataBaseItem := LastDataBaseItem+1;
        end
 else ReportError(1); {Attempt to read beyond MaxNumberOfDataBaseItems} 
end; {PutDatabaseItem}

procedure InitDataBase;
begin
   LastDataBaseItem := 0;
   if FileExists(StandardDataBase)
   then
      begin
      Assign(DataBaseFile,StandardDataBase);
      Reset(DataBaseFile);
      while not EOF(DataBaseFile) do
      begin
         GetDataBaseItem(K0R, LastDataBaseItem);
         ItemNameS[LastDataBaseItem] := K0R.Name;
         LastDataBaseItem := LastDataBaseItem+1;
      end;
      if   EOF(DataBaseFile)
      then if   LastDataBaseItem>0
           then LastDataBaseItem := LastDataBaseItem-1;
   end;
end; {InitDataBase}

function FindDataBaseName( Nstg : String ):LongInt;
var ThisOne : LongInt;
begin
   ThisOne          :=  0;
   FindDataBaseName := -1;
   while ThisOne<LastDataBaseItem do
   begin
      if   Nstg=ItemNameS[ThisOne]
      then begin
              FindDataBaseName := ThisOne;
              Exit;
           end;
      ThisOne := ThisOne+1;
   end;
end; {FindDataBaseName}

{======================= Init Unit ========================}
procedure InitLinearSystem;
begin
    BaseFileName     := '\PROGRA~1\SIGNAL~1\';
    StandardOutput   := BaseFileName + 'K0.wav';
    StandardInput    := BaseFileName + 'K0.wav';

    StandardDataBase := BaseFileName + 'Radar.sdb';

    InitAllSignals;
    InitDataBase;
    ReadWAVFile(K0R,K0B);
    ScaleAllData;
end; {InitLinearSystem}

begin {unit initialization code}
   InitLinearSystem;
end. {Unit LinearSystem}

BMP --> ICO...

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.

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.