unit RRUtils2001;



interface uses classes, windows, sysutils, Graphics, forms, controls, stdctrls, comctrls,

                extctrls, grids;



type

  EFileError = class( Exception );        // für FileCopy

  ENoTargetDirError = class( Exception ); // für FileCopy





  TCharSet = set of Char;

  TRRList = class( TList )

    procedure  Clear; override;

    destructor Destroy; override;

  end;

  TRRStrStack = class( TStringList )

    procedure Push( s: string );

    function  Pop: string;

    function  GetValue( name: string ): string;

    function  GetSecondValueOf( name: string ): string; // sucht das 2.Vorkommen und gibt dessen Wert zurück

  end;

  TIntArray = array of integer;

  TRRStr = class

    str: string;

    constructor Create( s: string );

  end;

  TNodeProcessCall = function ( node: TTreeNode ): string of object;

  TApplicationElement = class

    PI: TProcessInformation;

    constructor Create( a_pi: TProcessInformation );

  end;

  TApplications = class( TStringList )

    function  ExecApp( filename: string ): TProcessInformation;

    destructor Destroy; override;

  end;

  TFilenameCallback = procedure( user: pointer; path: string; searchRecord: TSearchRec );

  TFilenameEvent    = procedure( user: pointer; path: string; searchRecord: TSearchRec ) of object;

  TDirListEntry = class

    sr: TSearchRec;

    pathname: string;

    constructor Create( path: string; statusRecord: TSearchRec );

    function    AsString: string;

    procedure   RelativatePath( root: string );

      // setzt die jeweiligen Pfade in Bezug zu "root"

  end;



TStrArray = array of String;



procedure DeleteAllFilesIn( directory: string );

function  CountSubString( line, substr: string ): integer;

function  CreateFileList( directory: string ): TStringList;

function  Quoted( s: string ): string;

procedure ForEachFileDo( directory: string; user: pointer; todo: TFilenameCallback ); overload;

procedure ForEachFileDo( directory: string; user: pointer; todo: TFilenameEvent );    overload;

function  UserName: string;

function  matchRE( s: string; re: string ): boolean; // schaut, ob s der Regular Expression entspricht

function  StringGrid2CSV( sg: TStringGrid ): TStringList;

procedure SaveStringGridToFile( sg: TStringGrid; Filename: string );

procedure LoadStringGridFromFile( sg: TStringGrid; Filename: string );

function  Win2Unicode( s: string ): string;

function  UniCode2Win( s: string ): string;

function  RectExtent( r: TRect ): TPoint;

function  RectCenter( r: TRect ): TPoint;

procedure Wait( ms: integer );

function  KeyToChar( key: word; shift: TShiftState ): char;

function  ShortCutToChar( sc: TShortCut ): char;

function  GetTreeViewText( tv: TTreeView; npc: TNodeProcessCall ): string;

  // reiht alle Knoten aneinander, wenn npc nicht nil, dann wird npc für jeden Knoten aufgerufen

procedure RectSquareRatio( var Width, Height: integer; TargetExtension: integer ); //wandelt W und H ohne Verzerrung in TargetExtension

function  ExtractFileExtX( src: string ): string;

  // findet sie auch, bei relativen Pfaden mit Parametern und angefügten Ankern (z.b. index.html#4)

  // in jedem Fall wird nur die Extension zurückgegeben!

procedure AviExtension( aviFile: string; var w, h: cardinal );

procedure ReplaceText( var txt: string; toReplace, ReplaceBy: string );

procedure ReplaceXMLAttribute( var line: string; attributeName, newValue: string );

function  RScanStr( s: string; scan: char ): integer;

function  LenFormattedString( s: string; len: integer ): string;

procedure LnkExec( path, filename: string );

function  Distance( x, y, u, v: integer ): integer;  overload;

function  Distance( x, y, u, v: extended ): extended; overload;

function  SubnodeIndexOf( node: TTreeNode; s: string ): integer;

function  TreeNodePathstring( node: TTreeNode; del: char ): string;

function  TreeNodeMatchesPathString( node: TTreeNode; del: char; match: string ): boolean;

  // überprüft, ob der Pfad zum Knoten dem regulären Ausdruck match entspricht

procedure SelectNode( path: string; tv: TTreeView );

function  GetCurrentLine( memo: TMemo ): string;

function  GetCurrentLineNo( memo: TMemo ): integer;

function  GetLineNo( memo: TMemo; position: integer ): integer;

function  SeparateCommatext( s: string ): TStringList;

function  SeparateCommaInt( s: string ): TIntArray;

procedure SaveIntToStream( i: integer; st: TStream );

procedure LoadIntFromStream( var i: integer; st: TStream );

procedure SaveStringToStream( s: string; st: TStream );

procedure LoadStringFromStream( var s: string; st: TStream );

function  GetMemInfo: string;

function  GetDoubleClickSpeed: integer; // holt die Millsekunden für Double-Click aus der Registry

function  GetWorkArea( var work_left, work_top, work_width, work_height: integer ): TRect; // gibt die Desktop-Daten ohne Taskbar zurück

function  FindEXE( datafile, workdir: string ): string;

function  XMLMacroReplaced( s: string; const macros: array of string; const replacements: array of string ): string; // ersetzt "&<var>;", wenn in "macros" vorkommend

function  FileVarReplaced( path: string; const vars: array of string; const replacements: array of string ): string; // ersetzt "$(var)", wenn in "vars" vorkommend

procedure ListXMLMacroReplaced( sl: TStringList; macros, replacements: TStrings );

function  SeperateFilePath( path: string ): TStrArray; // listet die einzelnen Pfadkomponenten auf

function  CreateAbsolutePath( CurrentFile, relative: string ): string;

procedure HighHTMLConversion( var stream: TMemoryStream ); // alle html-Zeichen

procedure LowHTMLConversion( var stream: TMemoryStream ); // nur die Buchstaben

{ Transformation mit Extension und Rotation }

procedure TransformModelToScreen( x0, y0, dx, dy, fi: extended; u, v: extended; var x, y: integer );

procedure TransformScreenToModel( x0, y0, dx, dy, fi: extended; x, y: integer; var u, v: extended );

function  GetMainIniFilename: string; // gibt die Ini-Datei im Verzeichnis der Applikation zurück

function  TaskBarExtension: TRect;

procedure SetOptWithTaskBar( f: TForm; w, h, minW, minH: integer );

function  ConvertToFilename( s: string ): string; // konvertiert auch "/" in "_"

function  ConvertToFilepath( s: string ): string; // komplett mit Name; konvertiert keine "/"

function  ConvertToCommaText( s: string ): string;

function  VarEliminated( s: string; sa: array of string ): string;

function  AppDirectory: string;

function  GetFirstDigitVal( s: string ): byte;

procedure IADelete( var ia: TIntArray; pos: integer );

function  Max( ia: array of integer ): integer;

function  Min( ia: array of integer ): integer;

procedure Sort( var ia: array of integer );

function  WindowsDirectory: string;

function  SystemDirectory: string;

function  RandomNumberOf( ia: array of integer ): integer;

function  RandomStringOf( sa: array of string; var s: string ): integer;

procedure RandomKAusN( n: array of integer; var k: array of integer );

function  CharStatistics( s: string; first, last: char ): TIntArray; // gibt die Häufigkeiten der einzelnen Chars zw. first und last zurück

procedure CountConditions( var right, amount: integer; ca: array of boolean );

function  CheckIn( s: string; cs: TCharSet ): boolean; // schaut nach, ob die Zeichen im Charset liegen

function  CheckEditStr( ed: TEdit; s: string ): boolean;

function  CheckTheBoxes( cba: array of TCheckBox; sol: array of boolean ): boolean;

procedure FileCopy( src, dst: string );

procedure SetStringFromAppParameter( c: char; var s: string );

{ überprüft die Kommandozeilenparameter; wenn "/"+char vorkommt, dann

  wird alles weitere nach s geschrieben }

function  GetCommandLineOptions: string;

procedure Mix( var ia: array of integer ); // Mischt das Array per Zufall ("Permutiert")

function  MixColor( c1, c2: TColor ): TColor;

function EditVal( ed: TEdit; var res: extended ): boolean;

function KillAllChars( s: string; ToKill: TCharSet ): string; // Nimmt alle in "ToKill" enthaltenen Zeichen raus

function KillAllSpaces( s: string ): string; // Nimmt nur die Leerzeichen raus

function KillLeadingWhite( s: string ): string; // Nimmt alle führenden Zeichen in #0..#32 raus

function KillSurroundingWhite( s: string ): string; // Nimmt alle führenden Zeichen in #0..#32 raus

function KillAllWhite( s: string ): string; // Nimmt alles in #0..#32 raus

function KillAllCtrls( s: string ) : string; // Nimmt alles in #0..#32 raus

function SpaceStr( count: integer ): string; // Gibt einen Leerzeichenstring aus

function ZeroStr( count: integer ): string; // Gibt eine Anzahl Nullen zurück

function Len( p1, p2: TPoint ): integer;

function DiffVector( p1, p2: TPoint; Len: integer ): Tpoint;

function PtIsInRect( p: TPoint; r: TRect ): boolean;

function PtIsInRectEnv( p: TPoint; rc: TPoint; rw2: integer ): boolean;

function PtIsNear( p1, p2: TPoint; distance: integer ): boolean;

function CoordsAreNear( x1, y1, x2, y2, distance: integer ): boolean;

function Red( col: TColor ): byte;

function Green( col: TColor ): byte;

function Blue( col: TColor ): byte;

procedure SafeHTransparentCopy( src, dst: TBitmap; dst_x, dst_y: integer );

procedure HTransparentCopy( src, dst: TBitmap; dst_x, dst_y: integer; t, m: extended ); // lineare Funktion

procedure VTransparentCopy( src, dst: TBitmap; dst_x, dst_y: integer; t, m: extended ); // lineare Funktion

procedure TransparentCopy( src, dst: TBitmap; dst_x, dst_y: integer; tx, mx, ty, my: extended );

procedure TransparentQCopy( src, dst: TBitmap; dst_x, dst_y: integer; ax, bx, cx, ay, by, cy: extended ); // quadtat. Fkt

// kopiert src transparent auf dst, indem die Trasnparenz in x- und y-Richtung durch lineare Fkt. bestimmt wird

procedure HFloat( C: TCanvas; Color, Color2: TColor; w, h, sx: integer );

procedure VFloat( C: TCanvas; Color, Color2: TColor; w, h, sy: integer );

procedure VGlass( src: TBitmap; FrameRadius: integer );



procedure FillImage( background, pattern: TBitmap );

// füllt ein bitmap mit dem patternbitmap



procedure FillBackground( panel: TControl; Image: TImage; bitmap: TBitmap );

// panel: soll gefüllt werden // image: Komponente (wird ans Panel angepasst) // bitmap: das Pattern



procedure ColorDimmerX( Canvas: TCanvas; x, y, w, h: integer; col1, col2: TColor );

procedure ColorDimmerY( Canvas: TCanvas; x, y, w, h: integer; col1, col2: TColor );



function AppExec( Filename: string ): TProcessInformation;

{ Ruft "CreateProcess" auf.

  Bei Erfolg steht in TProcessInformation.hProcess eine Zahl <> $ffff }



procedure CloseApplication( pi: TProcessInformation ); // muss noch implementiert werden!



function ExecAndWait( SenderForm: TForm;

                      const Filename, Params: string; WindowState: word): boolean;

{  Ruft eine Applikation via CreateProcess auf und wartet "hidden",

   bis diese Applikation beendet ist }



function PercentToStr( p: extended ): string;

{ Wandelt eine Float in die entsprechende Prozentzahl um;

  dabei wird auf die erste Dezimale der Prozentzahl gerundet }



function fac( n: integer ): longint;

{ Berechnung der Fakultät }



function k_aus_n( k, n: integer ): longint;

{ Berechnung von k aus n (Kombinatorik) }



function power( p: extended; n: integer ): extended;

{ Ganzzahlige Potenzen }



function Bernoulli( k, n: integer; p: extended ): extended;

{ Berechnung einer Bernoulli-Kette }



function Binomial( k1, k2, n: integer; p: extended ): extended;

{ Berechnung eines Teils einer Binomialverteilung }



procedure PaintLines( Canvas: TCanvas; pa: array of TPoint; deltax, deltay: integer; fac: extended; color: TColor; Width: integer );

{ Zeichnet schattierte Linien; dabei werden grundsätzlich immer zwei Punkte als Endpunkte einer Linie verwendet}



procedure MemInfo;



type

TLineEnd = ( leNone, leArrow, leThinArrow );

procedure DrawLineEnd( c: TCanvas; p1, p2: TPoint; ArrowSize: TPoint; kind: TLineEnd );

{ Pfeilsymbole für Linien; stammt ursprünglich aus mm }



type

THistory = class( TStringList )

  private

    procedure AdjustButtons;

  public

    Position : integer;

    fFwd, fBck : TControl;

    constructor Create( Fwd, Bck: TControl );

    procedure   AddPage( s: string );

    procedure   Bck;

    procedure   Fwd;

    procedure   First;

end;



implementation uses dialogs, messages, shellAPI, menus, registry;



var

  fLastMemory: longword;



function Len; begin

  Result := Round( sqrt( sqr( p2.x-p1.x ) + sqr( p2.y-p1.y ) ) );

end;

function DiffVector; var dx, dy: integer; r, ex, ey: extended; begin

  dx := p2.x-p1.x; dy := p2.y-p1.y;

  r := sqrt( sqr( dx ) + sqr( dy ) );

  if r = 0 then begin

    result := Point( 0, 0 ); exit;

  end;

  ex := dx/r; ey := dy/r;

  result.x := Round(ex*len); result.y := Round(ey*len);

end;

function PtIsInRect; begin

  result := (r.Left <= p.x) and (p.x <= r.Right) and (r.Top <= p.y) and (p.y <= r.Bottom);

end;

function PtIsInRectEnv; begin

  result := (rc.x-rw2 <= p.x) and (p.x <= rc.x+rw2) and (rc.y-rw2 <= p.y) and (p.y <= rc.y+rw2);

end;

function AppExec;

var ProcInfo: TProcessInformation; StartUpInfo: TStartUpInfo; dwCreationFlags: DWord; i: integer;

begin

//  dwCreationFlags := NORMAL_PRIORITY_CLASS;

  for i := 1 to length(Filename) do if filename[i] = '''' then filename[i] := '"';

  with StartUpInfo do begin

    lpReserved := nil;

    lpDesktop  := nil;

    lpTitle    := nil;

    dwFlags    := 0;

    wShowWindow := SW_SHOWNORMAL;

    cbReserved2 := 0;

    lpReserved2 := nil;

  end;

  dwCreationFlags := 0;

  if Createprocess( nil, pchar( Filename ), nil, nil, true, dwCreationFlags, nil, nil, StartUpInfo, ProcInfo ) then begin

    result := ProcInfo;

  end else begin

    result.hProcess := $ffff;

  end;

end;

procedure CloseApplication; begin

end;

function PercentToStr( p: extended ): string; begin

  result := FloatToStr( Round( p*1000 )/10 );

end;

function fac; var i: integer; begin

  result := 1;

  for i := 2 to n do result := result*i;

end;

function k_aus_n; var r1, r2: longint; i: integer; begin

  if (n = 0) or (k = 0) or (k = n) then begin

    result := 1; exit;

  end;

  r1 := n; r2 := 1;

  for i := 2 to k do begin

    dec( n );

    r1 := r1*n;

    r2 := r2*i;

  end;

  result := r1 div r2;

end;

function Power; var i: integer; begin

  if n = 0 then begin result := 1; exit end;

  result := p;

  for i := 2 to n do result := result*p;

end;

function Bernoulli; begin

  result := k_aus_n( k, n )*Power( p, n )*Power( 1-p, n-k );

end;

function Binomial; var i: integer; begin

  result := 0;

  for i := k1 to k2 do result := result + Bernoulli( i, n, p );

end;

procedure DrawLineEnd( c: TCanvas; p1, p2: TPoint; ArrowSize: TPoint; kind: TLineEnd );

var dx, dy: integer; r, ex, ey: extended; begin

  with c do begin

    dx := p2.x-p1.x; dy := p2.y-p1.y;

    r := sqrt( sqr(dx) + sqr(dy) );

    if r = 0 then exit;

    ex := dx/r; ey := dy/r;

    case kind of

      leArrow:

        PolyLine( [p2,

          Point( p2.x-Round(ex*ArrowSize.x+ey*ArrowSize.y),p2.y-Round(ey*ArrowSize.x-ex*ArrowSize.y)),

          Point( p2.x-Round(ex*ArrowSize.x-ey*ArrowSize.y),p2.y-Round(ey*ArrowSize.x+ex*ArrowSize.y)),

                   p2] );

      leThinArrow:

        PolyLine( [p2,

          Point( p2.x-Round(ex*ArrowSize.x+ey*ArrowSize.y),p2.y-Round(ey*ArrowSize.x-ex*ArrowSize.y)),

          p2,

          Point( p2.x-Round(ex*ArrowSize.x-ey*ArrowSize.y),p2.y-Round(ey*ArrowSize.x+ex*ArrowSize.y)),

                   p2] );

    end; // case

  end;

end;



procedure FillImage; var i, j, w, h, u, v: integer; bh, ph: word; begin

  with Background do begin

    w := Width; h := height;

  end;

  with Pattern do begin

    u := Width; v := height;

  end;

  bh := Background.Canvas.Handle;

  ph := Pattern.Canvas.Handle;

  for i := 0 to w div u do begin

    for j := 0 to h div v do begin

      BitBlt( bh, i*u, j*v, u, v, ph, 0, 0, srcCopy );

    end;

  end;

end;



function PtIsNear; begin

  result := Len( p1, p2 ) < distance;

end;



function CoordsAreNear; begin

  result := PtIsNear( Point( x1, y1 ), Point( x2, y2 ), distance );

end;





function ExecAndWait( SenderForm: TForm;

                      const Filename, Params: string; WindowState: word): boolean;

var

  SUInfo: TStartupInfo;

  ProcInfo: TProcessInformation;

  CmdLine: string;  // res: integer;

begin

  { Enclose filename in quotes to take care of long filenames WITH spaces. }

  CmdLine := '"' + Filename + '" '+ Params;

  FillChar(SUInfo, SizeOf(SUInfo), #0);

  with SUInfo do begin

    cb := SizeOf(SUInfo);

    dwFlags := STARTF_USESHOWWINDOW;

    wShowWindow := WindowState;

  end;

  result := CreateProcess(NIL, PChar(CmdLine), NIL, NIL, FALSE,

                          CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, NIL,

                          PChar(ExtractFilePath(ExpandFileName(Filename))),

                          SUInfo, ProcInfo);

  { Wait for it to finish. }

  if Result then begin

    try

      SenderForm.Cursor := crHourGlass;

      {res :=} WaitForInputIdle( ProcInfo.hProcess, 30000 );

//      SendMessage( Senderform.Handle, wm_User, 5, 0 );

      SenderForm.hide;

      WaitForSingleObject(ProcInfo.hProcess, INFINITE);

      Senderform.show

    finally

      SenderForm.Cursor := crDefault;

    end;

  end else begin

    showmessage('"'+Filename+'"'+' konnte nicht geladen werden. ('+IntToStr( GetLastError )+')'+#13+

                 'Aufrufparameter: '+ Params);   // zu finden in Windows.ERROR (Symbolanzeige)

  end;

end;



procedure FillBackground( panel: TControl; Image: TImage; bitmap: TBitmap ); begin

  Image.SendToBack;

  Image.Width := Panel.Width;

  Image.Height := Panel.Height;

  with Image.Picture.Bitmap do begin

    Width := Image.Width; Height := Image.Height;

  end;

  FillImage( Image.Picture.Bitmap, Bitmap );

end;



{ THistory }



procedure THistory.AddPage(s: string);

begin

  Position := Add( s );

  AdjustButtons;

end;



procedure THistory.AdjustButtons;

begin

  FBck.Enabled := Position > 0;

  FFwd.Enabled := Position < Count-1;

end;



procedure THistory.Bck;

begin

  if Position = -1 then exit

  else if Position > 0 then dec( Position );

  AdjustButtons;

end;



constructor THistory.Create(Fwd, Bck: TControl);

begin

  fFwd := Fwd; fBck := Bck; Position := -1;

  inherited Create;

end;



procedure THistory.First;

begin

  Position := 0;

  AdjustButtons;

end;



procedure THistory.Fwd;

begin

  if Position = -1 then exit

  else if Position < Count-1 then inc( Position );

  AdjustButtons;

end;



procedure ColorDimmerX( Canvas: TCanvas; x, y, w, h: integer; col1, col2: TColor );

var i: integer; col: TColor; begin

  with Canvas do begin

    Pen.Style := psClear;

    Brush.Style := bsSolid;

  end;

  for i := 0 to 31 do begin

    col := RGB( Round( i*Red( col2 )/32 + (32-i)*Red( col1 )/32 ),

                Round( i*Green( col2 )/32 + (32-i)*Green( col1 )/32 ),

                Round( i*Blue( col2 )/32 + (32-i)*Blue( col1 )/32 ) );

    Canvas.Brush.Color := col;

    Canvas.Rectangle( x+Round(i*w/32), y, x+Round((i+1)*w/32)+1, y+h );

  end;

end;

procedure ColorDimmerY( Canvas: TCanvas; x, y, w, h: integer; col1, col2: TColor );

var i: integer; col: TColor; begin

  with Canvas do begin

    Pen.Style := psClear;

    Brush.Style := bsSolid;

  end;

  for i := 0 to 31 do begin

    col := RGB( Round( i*Red( col2 )/32 + (32-i)*Red( col1 )/32 ),

                Round( i*Green( col2 )/32 + (32-i)*Green( col1 )/32 ),

                Round( i*Blue( col2 )/32 + (32-i)*Blue( col1 )/32 ) );

    Canvas.Brush.Color := col;

    Canvas.Rectangle( x, y+Round(i*h/32), x+w, y+Round((i+1)*h/32)+1 );

  end;

end;



function Red( col: TColor ): byte; begin

  result := col and $ff;

end;

function Green( col: TColor ): byte; begin

  result := (col shr 8) and $ff;

end;

function Blue( col: TColor ): byte; begin

  result := (col shr 16) and $ff;

end;



procedure SetStringFromAppParameter; var t: string; i: integer; begin

  s := '';

  for i := 1 to ParamCount do begin

    t := ParamStr( i );

    if (t[1] = '/') and (UpCase(t[2]) = UpCase(c)) then s := Copy( t, 3, 255 );

  end;

end;



function  GetCommandLineOptions: string; var i: integer; t: string; begin

  result := '';

  for i := 1 to ParamCount do begin

    t := ParamStr( i );

    if (t[1] = '/') then begin

      if Length( t ) > 1 then begin result := result + t[2]; end;

    end;

  end;

end;



procedure PaintLines;



  procedure PaintColoredLine( Canvas: TCanvas; p1, p2: TPoint; fac: extended; Color: TColor; Width: integer );

  var s: array[0..3] of integer; i: integer; begin

    s[0] := p1.x; s[1] := p1.y; s[2] := p2.x; s[3] := p2.y;

    for i := 0 to 3 do begin

      s[i] := Round( s[i]*Fac );

    end;

    if fac < 1 then begin

      if (s[0] < s[2]) and (s[1] = s[3]) then inc( s[2] );

      if (s[1] < s[3]) and (s[0] = s[2]) then inc( s[3] );

    end;

    with Canvas do begin

      Pen.Color := Color; Pen.Width := Width;

      moveto( s[0], s[1] ); lineto( s[2], s[3] );

    end;

  end;



var i, j: integer; p: array[0..1] of TPoint; begin

  for i := 0 to High( pa ) div 2 do begin

    for j := 0 to 1 do begin

      p[j] := pa[i*2+j];

      inc( p[j].x, DeltaX );

      inc( p[j].y, DeltaY );

    end;

    PaintColoredLine( Canvas, p[0], p[1], fac, color, Width );

  end;

end;



procedure SafeHTransparentCopy;

var i, j, w, h: integer; r, g, b: integer; c: array[0..1] of TColor;

    e: extended;

begin

  w := src.Width; h := src.Height;

  for i := 0 to w-1 do begin

    for j := 0 to h-1 do begin

      c[0] := dst.Canvas.Pixels[dst_x+i,dst_y+j];

      c[1] := src.Canvas.Pixels[i,j];

      e := i/w;

      r := Round( e*Red( c[0] ) + (1-e)*Red( c[1] ) );

      g := Round( e*Green( c[0] ) + (1-e)*Green( c[1] ) );

      b := Round( e*Blue( c[0] ) + (1-e)*Blue( c[1] ) );

      dst.Canvas.Pixels[dst_x+i,dst_y+j] := RGB( r, g, b );

    end;

  end;

end;

procedure HTransparentCopy;

var i, j, k, w, h, count: integer; p, q, z: PByteArray; e: extended; bm: TBitmap;

begin

  bm := TBitmap.Create;

  try

    w := src.Width; h := src.Height;

    with bm do begin

      Width := w; Height := h; PixelFormat := src.PixelFormat;

      BitBlt( Handle, 0, 0, w, h, src.Handle, 0, 0, srcCopy );

    end;

    case dst.PixelFormat of

      pf8Bit  : count := 1;

      pf24Bit : count := 3;

      pf16Bit : count := 2;

      pf32Bit : count := 4;

      else begin

        count := 2; dst.Pixelformat := pf16Bit;

      end;

    end;

    for j := 0 to h-1 do begin

      p := dst.Scanline[j+dst_y];

      q := src.ScanLine[j];

      z := bm.ScanLine[j];

      for i := 0 to w-1 do begin

        e := m*i/w + t;

        for k := 0 to count-1 do begin

          z[i*count + k] := Round( (1-e)*p[(i+dst_x)*count + k] + e*q[i*count + k] ) and $ff;

       end;

      end;

    end;

    dst.Canvas.Draw( dst_X, dst_y, bm );

//    BitBlt( dst.Canvas.Handle, dst_X, dst_Y, w, h, bm.Canvas.Handle, 0, 0, srcCopy );

  finally

    bm.Free;

  end;

end;

procedure VTransparentCopy;

var i, j, k, w, h, count: integer; p, q, z: PByteArray; e: extended; bm: TBitmap;

begin

  bm := TBitmap.Create;

  try

    w := src.Width; h := src.Height;

    with bm do begin

      Width := w; Height := h; PixelFormat := src.PixelFormat;

      BitBlt( Handle, 0, 0, w, h, src.Handle, 0, 0, srcCopy );

    end;

    case dst.PixelFormat of

      pf8Bit  : count := 1;

      pf24Bit : count := 3;

      pf16Bit : count := 2;

      pf32Bit : count := 4;

      else begin

        count := 2; dst.Pixelformat := pf16Bit;

      end;

    end;

    for j := 0 to h-1 do begin

      p := dst.Scanline[j+dst_y];

      q := src.ScanLine[j];

      z := bm.ScanLine[j];

      e := m*j/h + t;

      for i := 0 to w-1 do begin

        for k := 0 to count-1 do begin

          z[i*count + k] := Round( (1-e)*p[(i+dst_x)*count + k] + e*q[i*count + k] ) and $ff;

       end;

      end;

    end;

//    BitBlt( dst.Canvas.Handle, dst_X, dst_Y, w, h, bm.Canvas.Handle, 0, 0, srcCopy );

    dst.Canvas.Draw( dst_X, dst_y, bm );

  finally

    bm.Free;

  end;

end;



procedure TransparentCopy;

var i, j, k, w, h, count: integer; p, q, z: PByteArray; e, f: extended; bm: TBitmap;

begin

  bm := TBitmap.Create;

  try

    w := src.Width; h := src.Height;

    with bm do begin

      Width := w; Height := h; PixelFormat := src.PixelFormat;

      BitBlt( Handle, 0, 0, w, h, src.Handle, 0, 0, srcCopy );

    end;

    case dst.PixelFormat of

      pf8Bit  : count := 1;

      pf24Bit : count := 3;

      pf16Bit : count := 2;

      pf32Bit : count := 4;

      else begin

        count := 2; dst.Pixelformat := pf16Bit;

      end;

    end;

    for j := 0 to h-1 do begin

      p := dst.Scanline[j+dst_y];

      q := src.ScanLine[j];

      z := bm.ScanLine[j];

      f := my*j/h + ty;

      for i := 0 to w-1 do begin

        e := (mx*i/w + tx)*f; if e > 1 then e := 1 else if e < 0 then e := 0;

        for k := 0 to count-1 do begin

          z[i*count + k] := Round( (1-e)*p[(i+dst_x)*count + k] + e*q[i*count + k] ) and $ff;

       end;

      end;

    end;

//    BitBlt( dst.Canvas.Handle, dst_X, dst_Y, w, h, bm.Canvas.Handle, 0, 0, srcCopy );

    dst.Canvas.Draw( dst_X, dst_y, bm );

  finally

    bm.Free;

  end;

end;



procedure TransparentQCopy;

var i, j, k, w, h, count: integer; p, q, z: PByteArray; e, f, x, y: extended; bm: TBitmap;

begin

  bm := TBitmap.Create;

  try

    w := src.Width; h := src.Height;

    with bm do begin

      Width := w; Height := h; PixelFormat := src.PixelFormat;

      BitBlt( Handle, 0, 0, w, h, src.Handle, 0, 0, srcCopy );

    end;

    case dst.PixelFormat of

      pf8Bit  : count := 1;

      pf24Bit : count := 3;

      pf16Bit : count := 2;

      pf32Bit : count := 4;

      else begin

        count := 2; dst.Pixelformat := pf16Bit;

      end;

    end;

    for j := 0 to h-1 do begin

      p := dst.Scanline[j+dst_y];

      q := src.ScanLine[j];

      z := bm.ScanLine[j];

      y := j/h;

      f := ay*sqr(y)+by*y+cy;

      for i := 0 to w-1 do begin

        x := i/w;

        e := (ax*sqr(x)+bx*x+cx)*f; if e > 1 then e := 1 else if e < 0 then e := 0;

        for k := 0 to count-1 do begin

          z[i*count + k] := Round( (1-e)*p[(i+dst_x)*count + k] + e*q[i*count + k] ) and $ff;

       end;

      end;

    end;

//    BitBlt( dst.Canvas.Handle, dst_X, dst_Y, w, h, bm.Canvas.Handle, 0, 0, srcCopy );

    dst.Canvas.Draw( dst_X, dst_y, bm );

  finally

    bm.Free;

  end;

end;



procedure VGlass; var bm: TBitmap; fr3: integer; begin

  fr3 := FrameRadius div 3;

  bm := TBitmap.Create;

  bm.Width := src.Width; bm.Height := fr3;

  BitBlt( bm.Canvas.Handle, 0, 0, src.Width, fr3, src.Canvas.Handle, 0, 3, srcCopy );

  BitBlt( bm.Canvas.Handle, 0, fr3 + 1, src.Width, fr3, src.Canvas.Handle, fr3, fr3 + 3, srcCopy );

  BitBlt( bm.Canvas.Handle, 0, 2*fr3 + 1, src.Width, fr3, src.Canvas.Handle, fr3, 2*fr3 + 2, srcCopy );

  src.Canvas.Draw( 0, 0, bm );

  BitBlt( bm.Canvas.Handle, 0, 0, src.Width, fr3, src.Canvas.Handle, 0, src.Height-fr3-3, srcCopy );

  BitBlt( bm.Canvas.Handle, 0, fr3+1, src.Width, fr3, src.Canvas.Handle, fr3, src.Height-2*fr3 - 2, srcCopy );

  BitBlt( bm.Canvas.Handle, 0, 2*fr3+2, src.Width, fr3, src.Canvas.Handle, fr3, src.Height-3*fr3 - 1, srcCopy );

  src.Canvas.Draw( 0, src.Height-3*fr3, bm );

  bm.Free;

end;





procedure Mix;



  procedure Permutate( a, b: integer ); var t: integer; begin

    t := ia[a]; ia[a] := ia[b]; ia[b] := t;

  end;



var amount, i: integer; begin

  amount := Length( ia );

  for i := 1 to Amount do begin

    Permutate( Random(Amount), Random(Amount) );

  end;

end;



function MixColor; begin

  result := RGB( (Red(c1)+Red(c2)) div 2, (Green(c1)+Green(c2)) div 2, (Blue(c1)+Blue(c2)) div 2 );

end;



procedure HFloat;

var i, count, r1, r2, g1, g2, b1, b2: integer; fac: Extended; begin

  if sx < 3 then sx := 3;

  count := Round(w/SX); c.Pen.Style := psClear;

  r1 := Red( Color ); g1 := Green( Color ); b1 := Blue( Color );

  r2 := Red( Color2 )-r1; g2 := Green( Color2 )-g1; b2 := Blue( Color2 )-b1;

  C.Brush.Style := bsSolid;

  for i := 0 to count do begin

    fac := i/count;

    c.Brush.Color := RGB( r1+Round(fac*r2), g1+Round(fac*g2), b1+Round(fac*b2) );

    C.Rectangle( Round(i*SX), 0, Round((i+1)*SX)+1, h );

  end;

end;

procedure VFloat;

var i, count, r1, r2, g1, g2, b1, b2: integer; fac: Extended; begin

  if sy < 3 then sy := 3;

  count := Round(h/sy); c.Pen.Style := psClear;

  r1 := Red( Color ); g1 := Green( Color ); b1 := Blue( Color );

  r2 := Red( Color2 )-r1; g2 := Green( Color2 )-g1; b2 := Blue( Color2 )-b1;

  C.Brush.Style := bsSolid;

  for i := 0 to count do begin

    fac := i/count;

    c.Brush.Color := RGB( r1+Round(fac*r2), g1+Round(fac*g2), b1+Round(fac*b2) );

    C.Rectangle( 0, Round(i*sy), w, Round((i+1)*sy)+1 );

  end;

end;



function KillAllChars; var i: integer;

begin

  result := '';

  for i := 1 to Length( s ) do begin

    if not (s[i] in ToKill) then result := result + s[i];

  end;

end;

function KillAllWhite; var i: integer; begin

  result := '';

  for i := 1 to Length( s ) do if not (s[i] < #33) then result := result + s[i];

end;

function KillLeadingWhite; var i: integer; begin

  result := '';

  i := 1;

  while ord(s[i]) <= 32 do inc( i );

  result := Copy( s, i, 255 );

end;

function KillSurroundingWhite; var i: integer; begin

  s := KillLeadingWhite( s );

  i := Length( s );

  while ord(s[i]) <= 32 do dec( i );

  result := Copy( s, 1, i );

end;

function KillAllCtrls; var i: integer; begin

  result := '';

  for i := 1 to Length( s ) do if not (s[i] < #32) then result := result + s[i];

end;

function KillAllSpaces; var i: integer; begin

  result := '';

  for i := 1 to Length( s ) do begin

    if not (s[i] = ' ') then result := result + s[i];

  end;

end;



{ TRRList }



procedure TRRList.Clear; var i: integer;

begin

  for i := 0 to Count-1 do TObject( Items[i] ).Free;

  inherited Clear;

end;



destructor TRRList.Destroy;

begin

  Clear;

  inherited Destroy;

end;



function EditVal( ed: TEdit; var res: extended ): boolean; var i: integer; s: string; begin

  s := ed.Text;

  for i := 1 to Length( s ) do if s[i] = '.' then s[i] := ',';

  result := true; res := 0;

  try

    res := StrToFloat( s );

  except

    on EConvertError do result := false;

  end;

end;



procedure MemInfo; var ms: TMemoryStatus; m, t, e: integer; s: string;

begin

  ms.dwLength := SizeOf( ms );

  GlobalMemoryStatus( ms );

  m := ms.dwAvailPhys;

  e := m mod 1000;

  t := (m div 1000) mod 1000;

  m := m div 1000000;

  if ms.dwAvailPhys > fLastMemory then s := 'zugenommen' else s := 'abgenommen!';

  ShowMessage( Format( '%.3d %.3d %.3d; um %d ',[m,t,e,abs(ms.dwAvailPhys-fLastMemory)] )+s );

  fLastMemory := ms.dwAvailPhys;

end;





procedure FileCopy; var p1, p2: array[0..255] of char; b: boolean;

begin

  if ExtractFileExt( src ) <> ExtractFileExt( dst ) then begin

    dst := dst+'\'+ExtractFilename( src );

  end;

  if not DirectoryExists( ExtractFilePath(src) ) then raise EFileError.Create( 'Quellpfad "'+ExtractFilePath(src)+'" existiert nicht' );

  if not FileExists( src ) then raise EFileError.Create( 'Quelldatei "'+src+'" existiert nicht' );

  if not DirectoryExists( ExtractFilePath(dst) ) then raise ENoTargetDirError.Create( 'Zielpfad "'+ExtractFilePath(dst)+'" existiert nicht' );

  b := false;

  StrPCopy( p1, src );

  StrPCopy( p2, dst );

  CopyFile( p1, p2, b );

end;



const

  CSpace = '                                                                                                                  ';

function SpaceStr( count: integer ): string; begin

  result := CSpace;

  SetLength( result, count );

end;



const

  CZero = '000000000000000000000000000000000000000000000000000000000000000000';

function ZeroStr( count: integer ): string; begin

  result := CZero;

  SetLength( result, count );

end;



function CheckIn; var i: integer;

begin

  result := false;

  for i := 1 to Length( s ) do begin

    if not (s[i] in cs) then exit;

  end;

  result := true;

end;



function CheckEditStr; begin

  result := Trim( ed.Text ) = s;

  if not result then ed.Color := clRed;

end;



procedure CountConditions; var i: integer; begin

  inc( amount, Length( ca ) );

  for i := 0 to high( ca ) do begin

    if ca[i] then inc( right );

  end;

end;



function  CharStatistics( s: string; first, last: char ): TIntArray; var i: integer;

begin

  SetLength( result, ord(last)-ord(first)+1 );

  for i := 1 to Length( s ) do begin

    if (s[i] >= first) and (s[i] <= last) then begin

      inc( result[ord(s[i])-ord(first)] );

    end;

  end;

end;



function  RandomNumberOf( ia: array of integer ): integer; var i: integer; begin

  i := Random( Length( ia ) );

  result := ia[i];

end;



function  RandomStringOf( sa: array of string; var s: string ): integer; var i: integer; begin

  i := Random( Length( sa ) );

  s := sa[i];

  result := i;

end;



function WindowsDirectory: string; var wd: array[0..255] of char; begin

  GetWindowsDirectory( wd, 256 );

  result := strpas( wd );

end;

function SystemDirectory: string; var wd: array[0..255] of char; begin

  GetSystemDirectory( wd, 256 );

  result := strpas( wd );

end;

function Max; var i: integer; begin

  result := -MaxInt;

  for i := 0 to high( ia ) do if ia[i] > result then result := ia[i];

end;

function Min; var i: integer; begin

  result := MaxInt;

  for i := 0 to high( ia ) do if ia[i] < result then result := ia[i];

end;

procedure IADelete; var i: integer; begin

  for i := pos to High( ia )-1 do begin

    ia[i] := ia[i+1];

  end;

  SetLength( ia, Length( ia )-1 );

end;

function  CheckTheBoxes( cba: array of TCheckBox; sol: array of boolean ): boolean; var i, m: integer; b: boolean; begin

  m := Min( [High( cba ), high( sol )] );

  result := true;

  for i := 0 to m do begin

    b := (cba[i].Checked = sol[i]);

    result := result and b;

    if not b then cba[i].Color := clRed;

  end;

end;

procedure RandomKAusN( n: array of integer; var k: array of integer ); var i, p: integer; temp: TIntArray;

begin

  if Length( k ) > Length( n ) then exit;

  SetLength( temp, Length( n ) );

  for i := 0 to high( temp ) do begin

    temp[i] := n[i];

  end;

  for i := 0 to high( k ) do begin

    p := Random(Length(temp));

    k[i] := temp[p];

    IADelete( temp, p );

  end;

  Sort( k );

end;

procedure Sort( var ia: array of integer );

  procedure qsort( l, r: integer ); var i, j: integer; x, w: integer; begin

    i := l; j := r;

    x := ia[(l+r) div 2];

    repeat

      while ia[i] < x do inc( i );

      while x < ia[j] do dec( j );

      if i <= j then begin

        w := ia[i]; ia[i] := ia[j]; ia[j] := w; inc( i ); dec( j );

      end;

    until i > j;

    if l < j then qsort( l, j );

    if i < r then qsort( i, r );

  end;

begin

  qsort( 0, high( ia ) );

end;



function  GetFirstDigitVal( s: string ): byte; var i: integer; begin

  result := 0;

  for i := 1 to Length( s ) do begin

    if s[i] in ['0'..'9'] then begin

      result := ord( s[i] ) - 48;

      exit;

    end;

  end;

end;



function AppDirectory: string; var s: string; begin

  s := ParamStr( 0 );

  result := ExtractFilepath( s );

end;



function VarEliminated( s: string; sa: array of string ): string; var i: integer; c: char; begin

  if Pos( '%', s ) = 0 then begin result := s; exit; end;

  SetLength( result, 0 );

  i := 1;

  while i <= Length( s ) do begin

    c := s[i];

    if (c = '%') and (i < Length(s)) and (s[i+1] in ['1'..'9']) then begin

      c := s[i+1];

      if {(low(sa) <= ord(c)-49) and} (ord(c)-49 <= high(sa)) then result := result + sa[ ord(c)-49 ]

      else result := result + '%ERROR!';

      inc( i );

    end else begin

      result := result + c;

    end;

    inc( i );

  end;

end;



function ConvertToFilepath( s: string ): string; var i: integer; p: string; begin

  p := ExtractFilePath( s );

  s := ExtractFilename( s );

  i := pos( 'ß', s );

  while i > 0 do begin

    s[i] := 's'; system.Insert( 's', s, i );

    i := pos( 'ß', s );

  end;

  for i := 1 to Length( s ) do begin

    case s[i] of

      ' ' : s[i] := '_';

      'ä' : s[i] := 'a';

      'ö' : s[i] := 'o';

      'ü' : s[i] := 'u';

      'Ä' : s[i] := 'A';

      'Ö' : s[i] := 'O';

      'Ü' : s[i] := 'U';

      'ß' : s[i] := 's';

    end;

  end;

  result := LowerCase( p+s );

end;



function ConvertToFilename( s: string ): string; var i: integer; begin

  s := ConvertToFilePath( s );

  for i := 1 to Length( s ) do begin

    case s[i] of

      ' ',':','/','\' : s[i] := '_';

    end;

  end;

  result := LowerCase( s );

end;



function ConvertToCommatext; var i: integer; begin

  for i := 1 to Length( s ) do begin

    case s[i] of

      ';' : s[i] := ',';

      ',' : s[i] := '.';

    end;

  end;

  result := s;

end;



function  TaskBarExtension: TRect; var Taskhandle: THandle; begin

  Taskhandle:= FindWindow('Shell_TrayWnd', nil);

  GetWindowRect(Taskhandle, result);

end;



procedure SetOptWithTaskBar( f: TForm; w, h, minW, minH: integer ); var x: integer; r: TRect;

  procedure SetHorzX; begin

    x := 2+Screen.Width - (r.Right - r.Left);

    if x < w then begin w := x; if w < minW then w := minW end;

  end;

  procedure SetVertX; begin

    x := 2+Screen.Height - (r.Bottom - r.Top);

    if x < h then begin h := x; if h < minH then h := minH end;

  end;

begin

  r := TaskBarExtension;

  if r.Top <= 0 then begin // TaskBar nicht unten!

    if r.Left > 0 then begin // TaskBar rechts

      SetHorzX;

      f.SetBounds( (x-w) div 2, (Screen.Height-h) div 2, w, h );

    end else begin

      if r.Bottom > r.Right then begin // taskbar links

        SetHorzX;

        f.SetBounds( r.Right+(x-w) div 2, (Screen.Height-h) div 2, w, h );

      end else begin // Taskbar oben

        SetVertX;

        f.SetBounds( (Screen.Width-w) div 2, r.Bottom+(x-h) div 2, w, h );

      end;

    end;

  end else begin

    SetVertX;

    f.SetBounds( (Screen.Width-w) div 2, (x-h) div 2, w, h );

  end;

end;

function  GetMainIniFilename: string; // gibt die Ini-Datei im Verzeichnis der Applikation zurück

var s: string;

begin

  s := ParamStr( 0 );

  SetLength( s, Length( s ) - 4 ); // .exe beseitigt

  s := s + '.ini';

  result := s;

end;



procedure TransformModelToScreen( x0, y0, dx, dy, fi: extended; u, v: extended; var x, y: integer );

begin

  u := u - 0.5;

  v := v - 0.5;

  x := Round( dx*cos( fi )*u   + dy*sin( fi )*v + x0 );

  y := Round( - dx*sin( fi )*u + dy*cos( fi )*v + y0 );

end;

procedure TransformScreenToModel( x0, y0, dx, dy, fi: extended; x, y: integer; var u, v: extended );

var a, b: extended;

begin

  a := x - x0;

  b := y - y0;

  u := 0.5 + a*cos( -fi )/dx + b*sin( -fi )/dy;

  v := 0.5 - a*sin( -fi )/dx + b*cos( -fi )/dy;

end;



type

ERRStackEmpty = class( Exception );



{ TRRStrStack }



function TRRStrStack.GetSecondValueOf(name: string): string;

var i, p: integer; s: string; first: boolean;

begin

  result := ''; first := false;

  for i := 0 to Count-1 do begin

    s := Strings[i];

    p := pos( '=', s );

    if p > 0 then begin

      if Copy( s, 1, p-1 ) = name then begin

        if not first then first := true

        else begin

          result := Copy( s, p+1, 255 );

          exit;

        end;

      end;

    end;

  end;

end;



function TRRStrStack.GetValue(name: string): string;

var i, p: integer; s: string;

begin

  result := '';

  for i := 0 to Count-1 do begin

    s := Strings[i];

    p := pos( '=', s );

    if p > 0 then begin

      if Copy( s, 1, p-1 ) = name then begin

        result := Copy( s, p+1, 255 );

        exit;

      end;

    end;

  end;

end;



function TRRStrStack.Pop: string;

begin

  if Count = 0 then raise ERRStackEmpty.Create( 'Stack ist leer!' );

  result := Strings[0];

  Delete( 1 );

end;



procedure TRRStrStack.Push(s: string);

begin

  Insert( 0, s );

end;



procedure LowHTMLConversion( var stream: TMemoryStream ); var ms: TMemoryStream; c: char; i: integer; begin

  ms := TMemoryStream.Create;

  for i := 1 to stream.Size do begin

    stream.Read( c, 1 );

    case c of

      'ä' : ms.write( '&auml;', 6 );

      'ö' : ms.write( '&ouml;', 6 );

      'ü' : ms.write( '&uuml;', 6 );

      'Ä' : ms.write( '&Auml;', 6 );

      'Ö' : ms.write( '&Ouml;', 6 );

      'Ü' : ms.write( '&Uuml;', 6 );

      'ß' : ms.write( '&szlig;', 7 );

      else ms.write( c, 1 )

    end;

  end;

  stream.Free;

  stream := ms;

end;



procedure HighHTMLConversion( var stream: TMemoryStream ); var ms: TMemoryStream; c: char; i: integer; begin

  stream.position := 0;

  ms := TMemoryStream.Create;

  for i := 1 to stream.Size do begin

    stream.Read( c, 1 );

    case c of

      'ä' : ms.write( '&auml;', 6 );

      'ö' : ms.write( '&ouml;', 6 );

      'ü' : ms.write( '&uuml;', 6 );

      'Ä' : ms.write( '&Auml;', 6 );

      'Ö' : ms.write( '&Ouml;', 6 );

      'Ü' : ms.write( '&Uuml;', 6 );

      'ß' : ms.write( '&szlig;', 7 );

      '<' : ms.write( '&lt;', 4 );

      '>' : ms.write( '&gt;', 4 );

      '&' : ms.write( '&amp;', 5 );

      '"' : ms.write( '&quot;', 6 );

      else ms.write( c, 1 )

    end;

  end;

  stream.Free;

  stream := ms;

end;



function  SeperateFilePath( path: string ): TStrArray; // listet die einzelnen Pfadkomponenten auf

var i: integer; s: string;

begin

  s := ''; SetLength( result, 0 );

  for i := 1 to Length( path ) do begin

    if path[i] in ['/','\',':'] then begin

      if Length( s ) > 0 then begin

        SetLength( result, Length( result ) + 1 );

        result[Length(result)-1] := s;

        s := '';

      end;

    end else s := s + path[i];

  end;

end;



function  XMLMacroReplaced( s: string; const macros: array of string; const replacements: array of string ): string;



  function MacroPos( s: string ): integer; var i: integer; begin

    result := -1;

    for i := 0 to high( macros ) do begin

      if s = macros[i] then begin result := i; exit end;

    end;

  end;



var i, p: integer; tmpvar: string;

begin

  i := 1; SetLength( result, 0 );

  while i <= Length( s ) do begin

    case s[i] of

      '&' : begin

        inc( i ); SetLength( tmpVar, 0 );

        repeat

          tmpVar := tmpVar+s[i]; inc( i );

        until (i >= Length( s )) or (s[i] = ';');

        if s[i] = ';' then begin

          p := MacroPos( tmpVar );

          if p >= 0 then begin

            result := result + replacements[p];

          end else result := result+'&'+tmpVar+';';

        end else result := result + '&'+tmpVar;

      end

      else result := result + s[i]

    end;

    inc( i );

  end; // while

end;



procedure ListXMLMacroReplaced( sl: TStringList; macros, replacements: TStrings );

var m, r: array of string; i: integer; s: string;

begin

  Setlength( m, macros.Count );

  SetLength( r, macros.Count );

  for i := 0 to macros.Count-1 do begin

    m[i] := macros.Strings[i];

    r[i] := replacements.Strings[i];

  end;

  for i := 0 to sl.Count-1 do begin

    s := sl.Strings[i];

    sl.Strings[i] := XMLMacroReplaced( s, m, r );

  end;

end;



function  CreateAbsolutePath( CurrentFile, relative: string ): string;

var i: integer; tmpDir: string; sa: TStrArray;

begin

  SetLength( sa, 0 );

  if (Pos( ':', relative ) > 0) and (Pos( '..', relative ) = 0) then begin

    // ein absoluter Pfad ist bereits eingestellt.. hier wird nix geändert!

    result := relative; exit;

  end;

  result := ExtractFilePath( CurrentFile );

  tmpDir := GetCurrentDir;

  if not SetCurrentDir( ExtractFilePath( CurrentFile ) ) then begin

    SetCurrentDir( tmpDir );

    exit;

  end;

  sa := SeperateFilePath( relative );

  for i := 0 to high( sa ) do begin

    if not SetCurrentDir( sa[i] ) then begin

      ShowMessage( 'Fehler beim Umwandeln eines relativen Pfads: '+sa[i]+' in '+GetCurrentDir+' nicht gefunden!' );

      SetCurrentDir( tmpDir );

      exit;

    end;

  end;

  result := GetCurrentDir;

  SetCurrentDir( tmpDir );

end;



function  FindEXE( datafile, workdir: string ): string;

var df, wd, ap: array[0..256] of char;

begin

  StrPCopy( df, datafile );

  StrPCopy( wd, workdir );

  FindExecutable( df, wd, ap );

  result := StrPas( ap );

end;



function  GetWorkArea( var work_left, work_top, work_width, work_height: integer ): TRect; var r: TRect; begin

  SystemParametersInfo( SPI_GETWORKAREA, 0, @r, 0 );

  work_left  := r.Left;         work_top    := r.Top;

  work_width := r.Right-r.Left; work_height := r.Bottom-r.Top;

end;



function GetDoubleClickSpeed: integer; var ri: TRegIniFile; begin

  ri := TRegIniFile.Create( 'Control Panel' );

  result := ri.ReadInteger( 'Mouse', 'DoubleClickSpeed', -1 );

  ri.Free;

end;



function GetMemInfo: string; var pms: _MemoryStatus;

begin

  pms.dwLength := SizeOf( pms );

  GlobalMemoryStatus( pms );

  result :=  'Speicherauslastung: '+IntToStr( pms.dwMemoryLoad )+'%; '+#13+#10+

             'Zur Verfügung stehen '+IntToStr( pms.dwAvailPhys div 1024)+

             ' von '+IntToStr( pms.dwTotalPhys div 1024)+' KBytes';

end;



procedure SaveStringToStream( s: string; st: TStream ); var l: integer; begin

  l := Length( s );

  st.Write( l, SizeOf( l ) );

  st.Write( s[1], l );

end;



procedure LoadStringFromStream( var s: string; st: TStream ); var l: integer; begin

  st.Read( l, SizeOf( l ) );

  if l = 0 then exit;

  SetLength( s, l );

  st.Read( s[1], l );

end;



procedure SaveIntToStream( i: integer; st: TStream ); begin

  st.Write( i, SizeOf( i ) );

end;



procedure LoadIntFromStream( var i: integer; st: TStream ); begin

  st.Read( i, SizeOf( i ) );

end;



function  SeparateCommatext( s: string ): TStringList; begin

  result := TStringList.Create;

  result.CommaText := s;

end;



function  SeparateCommaInt( s: string ): TIntArray; var sl: TStringList; i: integer; begin

  sl := SeparateCommatext( s );

  SetLength( result, sl.Count );

  for i := 0 to sl.Count-1 do begin

    try

      result[i] := StrToInt( sl.Strings[i] );

    except

      result[i] := 0;

    end;

  end;

end;





function  GetLineNo( memo: TMemo; position: integer ): integer;

var

  Buffer: PChar;

  Size: Byte;

  i : integer;

begin

  Size := memo.GetTextLen;        {Länge des Strings in Edit1 ermitteln}

  Inc(Size);                      {Platz für NULL-Zeichen hinzufügen}

  GetMem(Buffer, Size);           {Buffer als dynamische Variable definieren}

  memo.GetTextBuf(Buffer,Size);   {Edit1.Text in Buffer ablegen}

  result := 0;

  for i := 0 to position-1 do if buffer[i] = #13 then inc( result );

  FreeMem(Buffer, Size);{Speicher von Buffer freigeben}

end;

function  GetCurrentLineNo( memo: TMemo ): integer; begin

  result := GetLineNo( memo, memo.SelStart );

end;

function  GetCurrentLine( memo: TMemo ): string; begin

  result := memo.Lines[GetCurrentLineNo( memo )];

end;



function  SubnodeIndexOf( node: TTreeNode; s: string ): integer; var i: integer; begin

  result := -1;

  for i := 0 to node.count-1 do begin

    if node.Item[i].text = s then begin

      result := i; exit;

    end;

  end;

end;



function  Distance( x, y, u, v: integer ): integer;  overload; begin

  result := round(sqrt( sqr(x-u) + sqr(y-v) ));

end;



function  Distance( x, y, u, v: extended ): extended; overload; begin

  result := sqrt( sqr(x-u) + sqr(y-v) );

end;



procedure LnkExec( path, filename: string ); begin

  if path[Length(path)] <> '\' then path := path+'\';

  appexec( findexe( filename, path )+' '+path+filename );

end;



function  FileVarReplaced( path: string; const vars: array of string; const replacements: array of string ): string; // ersetzt "$(var)", wenn in "vars" vorkommend

var i, p: integer; s: string;

begin

  for i := 0 to high( vars ) do begin

    s := '$('+vars[i]+')';

    p := pos( s, path );

    if p > 0 then begin

      Delete( path, p, Length( s ) );

      Insert( replacements[i], path, p );

      result := path;

      exit;

    end;

  end;

  result := path;

end;



function  RScanStr( s: string; scan: char ): integer; var i: integer; begin

  for i := Length( s ) downto 1 do begin

    if s[i] = scan then begin result := i; exit end;

  end;

  result := 0;

end;



function  TreeNodePathstring( node: TTreeNode; del: char ): string; begin

  result := node.Text;

  while node.Parent <> nil do begin

    node := node.Parent;

    result := node.Text+del+result;

  end;

end;



function  TreeNodeMatchesPathString( node: TTreeNode; del: char; match: string ): boolean;

var s: string;

begin

  s := TreeNodePathString( node, del );

  result := matchRE( s, match );

end;



procedure ReplaceText( var txt: string; toReplace, ReplaceBy: string ); var p: integer; begin

  p := pos( toReplace, txt );

  while p > 0 do begin

    Delete( txt, p, Length( toReplace ) );

    Insert( ReplaceBy, txt, p  );

    p := pos( toReplace, txt );

  end;

end;



{ TRRStr }



constructor TRRStr.Create(s: string);

begin

  inherited Create;

  str := s;

end;



procedure SelectNode( path: string; tv: TTreeView );

var node: TTreeNode; i, j: integer; sl: TStringList; tmp: string;



  function CheckNodeInLevel( First: TTreeNode; searchstr: string ): TTreeNode; begin

    result := first;

    while result <> nil do begin

      if result.Text = searchstr then exit;

      result := result.GetNextSibling;

    end;

    if result <> nil then ShowMessage( 'Found '+searchstr );

  end;



begin

  tmp := '"';

  for i := 1 to Length( path ) do begin

    if path[i] in ['/','\'] then tmp := tmp + '","' else tmp := tmp + path[i];

  end;

  tmp := tmp+'"';

  path := tmp;

  sl := TStringList.Create;

  node := tv.Items.GetFirstNode;

  try

    sl.CommaText := path;

    for j := 0 to sl.Count - 1 do begin

      node := CheckNodeInLevel( node, sl[j] );

      if node = nil then break;

//      ShowMessage( node.text );

      if j < sl.Count-1 then node := node.GetFirstChild else node.Selected := true;

    end;

  finally

    sl.Free;

  end;

end;



procedure AviExtension( aviFile: string; var w, h: Cardinal ); var fs: TfileStream; begin

  fs := TFileStream.Create( aviFile, fmOpenRead );

  fs.Seek( 14, soFromBeginning );

  fs.Read( w, 2 ); w := w shr 16;

  fs.Read( h, 2 ); h := h shr 16;

  ShowMessage( IntToStr( w )+'..'+IntToStr( h ) );

  fs.Free;

end;



function  ExtractFileExtX( src: string ): string; var i: integer; reading: boolean; begin

  result := ''; reading := false;

  for i := 1 to Length( src )-1 do begin

    if reading then begin

      if not( UpCase(src[i]) in ['0'..'9','A'..'Z','Ä','Ö','Ü','_']) then exit;

      result := result + src[i];

    end;

    if src[i] = '.' then begin

      if not (src[i+1] in ['.','/','\']) then begin // sonst wäre es im relativen Pfad ein Ordner rauf

        result := '.';

        reading := true;

      end;

    end;

  end;

  if reading then result := result + src[Length(src)];

end;



procedure RectSquareRatio( var Width, Height: integer; TargetExtension: integer ); //wandelt W und H ohne Verzerrung in TargetExtension

var is_height: boolean; r: extended;

begin

  is_height := Height > Width;

  if is_height then r := TargetExtension/Height else r := TargetExtension/Width;

  Width := Round( r*Width ); Height := Round( r*Height );

end;



procedure RectRatioVariation( var Width, Height: integer; factor: extended );

begin

  Width := Round( factor*Width ); Height := Round( factor*Height );

end;



function  GetTreeViewText( tv: TTreeView; npc: TNodeProcessCall ): string; var item: TTreeNode; i: integer;

begin

  SetLength( result, 0 );

  item := tv.TopItem;

  while item <> nil do begin

    if Assigned( npc ) then result := result + npc( item )

    else begin // Standardbehandlung

      for i := 1 to item.level do result := result+' ';

      result := result+item.text+'<br>'+#13+#10;

    end;

    item := item.GetNext;

  end;

end;



function  ShortCutToChar( sc: TShortCut ): char;

var key: word; shift: TShiftState; c: char;

begin

//  ShowMessage( IntToStr( ord ( sc ) ) );

  ShortCutToKey( sc, key, shift );

  c := chr( key mod 255 );

  if not( ssShift in shift ) then inc( c, 32 );

  result := c;

end;



function  KeyToChar( key: word; shift: TShiftState ): char; begin

  result := chr( key mod 255 );

  if not( ssShift in shift ) then inc( result, 32 );

end;





{ TApplications }



destructor TApplications.Destroy;

var i: integer;

begin

  for i := 0 to Count-1 do begin

    TerminateProcess( TApplicationElement( Objects[i] ).PI.hProcess, 0 );

  end;

  inherited;

end;



function TApplications.ExecApp(filename: string): TProcessInformation;

var FProcInfo: TProcessInformation;

begin

  FProcInfo := AppExec( filename );

  AddObject( filename, TApplicationElement.Create( FProcInfo ) );

  result := FProcInfo;

end;



{ TApplicationElement }



constructor TApplicationElement.Create(a_pi: TProcessInformation);

begin

  inherited Create;

  pi := a_pi;

end;



procedure Wait( ms: integer ); var tmp: integer; begin

  tmp := GetTickCount();

  while GetTickCount() < tmp+ms do Application.ProcessMessages;

end;



function  RectCenter( r: TRect ): TPoint; begin

  with r do begin

    result.x := (left + right) div 2;

    result.y := (top+bottom) div 2;

  end;

end;



function  RectExtent( r: TRect ): TPoint; begin

  with r do begin

    result.x := Right-Left;

    result.y := Bottom-Top;

  end;

end;



const

  m: array[0..9] of string = ( 'lt', 'gt', '#228', '#246', '#252', '#196', '#214', '#220', '#178', '#179' );

  r: array[0..9] of string = ( '<', '>', 'ä', 'ö', 'ü', 'Ä', 'Ö', 'Ü', '²', '³' );



function Win2Unicode; 

var

  i, p: integer;

begin

  for i := 0 to high(m) do begin

    p := Pos( '&'+m[i]+';', s );

    while p > 0 do begin

      Delete( s, p, Length( m[i] ) + 2 );

      Insert( r[i], s, p );

      p := Pos( '&'+m[i]+';', s );

    end;

  end;

  result := s;

end;



function UniCode2Win;

var

  i, p: integer;

begin

  for i := 0 to high(m) do begin

    p := Pos( r[i], s );

    while p > 0 do begin

      Delete( s, p, 1 {Length( m[i] )} );

      Insert( '&'+m[i]+';', s, p );

      p := Pos( r[i], s );

    end;

  end;

  result := s;

end;



function  StringGrid2CSV( sg: TStringGrid ): TStringList;

var i, j: integer; s: string;

begin

  result := TStringList.Create;

  with sg do begin

    for j := 0 to rowcount-1 do begin

      s := '';

      for i := 0 to colcount-1 do begin

        s := s + '"'+sg.Cells[j,i]+'",';

      end;

      SetLength( s, Length( s ) - 1 );

      result.add( s );

    end;

  end;

end;



function  matchRE( s: string; re: string ): boolean; // schaut, ob s der Regular Expression entspricht

var pos: integer;

begin

  result := s = re;

  // aus re Automaten aufbauen

  pos := 1;

  while pos < Length( re ) do begin

    

  end;

  // Automaten entlanglaufen

end;

function UserName;

var s: array[0..127] of char; L: cardinal;

begin

  l := 127;

  windows.GetUserName( s, l );

  result := s;

end;

procedure ForEachFileDo( directory: string; user: pointer; todo: TFilenameCallback );

var sr: TSearchRec; path: string;

begin

  if FindFirst( directory+'\*.*', faAnyFile, sr ) = 0 then begin

    repeat

      if sr.Name[1] <> '.' then begin

        path := directory+'\'+sr.Name;

        if (sr.Attr and faDirectory <> 0) then begin // rekursiv weitermachen!

          forEachFileDo( path, user, todo );

        end else begin

          todo( user, directory, sr );

        end;

      end;

    until FindNext( sr ) <> 0;

    FindClose( sr );

  end;

end;

procedure ForEachFileDo( directory: string; user: pointer; todo: TFilenameEvent );

var sr: TSearchRec; path: string;

begin

  if FindFirst( directory+'\*.*', faAnyFile, sr ) = 0 then begin

    repeat

      if sr.Name[1] <> '.' then begin

        path := directory+'\'+sr.Name;

        if (sr.Attr and faDirectory <> 0) then begin // rekursiv weitermachen!

          forEachFileDo( path, user, todo );

        end else begin

          todo( user, directory, sr );

        end;

      end;

    until FindNext( sr ) <> 0;

    FindClose( sr );

  end;

end;

function Quoted; begin

  if Pos( ' ', s ) > 0 then result := '"'+s+'"' else result := s;

end;



{ TDirListEntry }



function TDirListEntry.AsString: string;

begin

  with sr do begin

    result := LenFormattedString( name, 20 )

      +LenFormattedString( DateTimeToStr( FileDateToDateTime( time ) ), 20 );

  end;

  result := result + pathname;

end;



constructor TDirListEntry.Create(path: string;

  statusRecord: TSearchRec);

begin

  pathname := path;

  sr := statusrecord;

end;



procedure AddFile( user: pointer; path: string; searchRecord: TSearchRec );

var sl: TStringList; dle: TDirListEntry;

begin

  sl := TStringList( user );

  dle := TDirListEntry.Create( path, searchRecord );

  sl.AddObject( dle.AsString, dle );

end;



function CreateFileList;

begin

  result := TStringList.Create;

  ForEachFileDo( directory, pointer( result ), AddFile );

end;



function  LenFormattedString( s: string; len: integer ): string; begin

  if Length( s ) > len then begin

    SetLength( s, len );

    result := s;

  end else begin

    result := s+SpaceStr( len-Length(s) );

  end;

end;



procedure TDirListEntry.RelativatePath(root: string);

begin

  if pos( root, pathname ) = 1 then delete( pathname, 1, Length( root ) );

end;



function  CountSubString( line, substr: string ): integer;

var p: integer;

begin

  result := 0;

  repeat

    p := Pos( substr, line );

    if p > 0 then begin delete( line, 1, p+Length( Substr ) ); end;

    inc( result );

  until p = 0;

end;



procedure ReplaceXMLAttribute( var line: string; attributeName, newValue: string );

var p, q: integer;

begin

  if CountSubstring( line, attributeName ) > 1 then begin

  end else begin

    p := Pos( attributeName, line );

    inc( p, Length( attributeName ) );

    while line[p] in [' ',#9] do inc( p );

    if line[p] <> '=' then exit;

    while line[p] in [' ',#9] do inc( p );

    if line[p] <> '"' then exit;

    q := p;

    while not (line[q] = '"') do inc( q );

  end;

end;



procedure SaveStringGridToFile( sg: TStringGrid; Filename: string );

var i: integer; sl: TStringList;

begin

  sl := TStringList.Create;

  for i := 0 to sg.RowCount-1 do begin

    sl.Add( sg.Rows[i].CommaText );

  end;

  sl.SaveToFile( Filename );

  sl.Free;

end;



procedure LoadStringGridFromFile( sg: TStringGrid; Filename: string );

var sl, sm: TStringList; i: integer;

begin

  sl := TStringList.Create;

  sl.LoadFromFile( Filename );

  sm := TStringList.Create;

  for i := 0 to sl.Count-1 do begin

    sm.Clear;

    sm.CommaText := sl[i];

    if i = 0 then begin

      sg.ColCount := sm.Count;

    end;

    if i >= sg.RowCount then begin

      sg.RowCount := sg.RowCount+1;

    end;

    sg.Rows[i].Assign( sm );

  end;

  sm.Free; sl.Free;

end;

procedure DeleteAllFilesIn( directory: string );

var sr: TSearchRec; path: string; sl: TStringList; i: integer;

begin

  sl := TStringList.Create;

  if FindFirst( directory+'\*.*', faAnyFile, sr ) = 0 then begin

    repeat

      if sr.Name[1] <> '.' then begin

        path := directory+'\'+sr.Name;

        if (sr.Attr and faDirectory <> 0) then begin // rekursiv weitermachen!

          DeleteAllFilesIn( path );

        end else begin

          sl.Add( path );

        end;

      end;

    until FindNext( sr ) <> 0;

    FindClose( sr );

  end;

  for i := 0 to sl.Count-1 do begin

    DeleteFile( sl[i] );

  end;

  sl.Free;

end;





end.