
Unit common;

INTERFACE
{
uwaga! Grubosc=bufor
}
//uses dos,crt;
uses 
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,friend;
{$F+} function HeapServ(drop:word):integer;
const       bufor = 499;//65535;    {jest to grubosc plastra na stercie -1}
       maxLbaBlok = 1199;           {przewidywana maksymalna lba plastrow}
           lbaBit = 12;
type     realType = double;
           TdbArr = array of double;
         realPlik = file of realType;
     ViewPortType = record x1,x2,y1,y2:integer; clip:boolean end;
 FillSettingsType = record pattern,color:word end;
 TextSettingsType = record font,direction,charsize,horiz,vert:word end;
          typ_skl = smallInt;//pierwotne word; zmiana 20.06.05 aby mozna było czytać dane z pliku Wav
              obs = array[0..bufor] of typ_skl;
      typ_sklFile = file of typ_skl;
             reft = ^obs;
          TrefTyp = array[0..maxLbaBlok] of reft;
VAR COUNT, F0Count : WORD;
          sqrCount : longWord;
              auth : shortString;
         drivePath : pathStr='C:\tp7';
            minLev : real=-60;     {parametry grafiki dla spektrum i sekcji}
            maxLev : real=0;
              tref : trefTyp;
              //cons : text;        //tymczasowo do write na ekran, blok 22032017
            locDrv : shortString; //directory where your program is located 28.04.2016
procedure no_jak(var znak:char);
procedure no_co(const question,title:pchar; var logik:boolean);
procedure Heap(var tref : TrefTyp;      {tablica wskaznikow na placki}
                 var SizeOfHeap : word);  {liczba plackow}

const max_buffer =2;                       {power of 2! (FFT)}

type v_l_vc =array[0..max_buffer-1] of realType;
    rAryType=array of double;//^v_l_vc;
var rek,rekl:boolean;
//procedure napis(var lancuch:String);
procedure fromHeap(pocz:longint; var tref:trefTyp; var xr:TdbArr;
 grubosc:word; count,lba_danych:longWord;sklSt:word; out error_code:integer);
//procedure fromHeap(pocz:longint; var tref:trefTyp; var xr:rAryType;
 //grubosc:word; count:longint;lba_danych:longint;bit:word;error_code:integer);
procedure convert(Gain:integer;var xr:TdbArr; count:word;var ymin,ymax:realType);
procedure convert_rel(Gain:integer; var xr:rAryType;count:word;
                      var ymin,ymax:realType);
//procedure music;

IMPLEMENTATION
uses unit1;
function HeapServ(drop:word):integer; begin HeapServ:=1 end;
//procedure puc; begin while KeyPressed do if ReadKey=#3 then halt; end;
procedure no_jak(var znak:char);
 begin (*puc; znak:=ReadKey; write(cons,' ',znak); puc *)end;

procedure no_co(const question,title:pchar; var logik:boolean);
 
 begin
  logik:=(application.messageBox(question,Title,MB_YESNO)=IDYES);
 end;
 (*
 procedure napis(var lancuch:String);
 var znak:char;
 begin
  lancuch :='';
  //puc;
  repeat
   znak:=ReadKey; write(cons,znak);
   if (znak<>#13) and (znak<>#10) and (znak<>#0) and (znak<>#8)
   then lancuch := lancuch + znak;
   if (znak=#0) or (znak=#8) then delete(lancuch,length(lancuch),1);
   puc
  until (znak=#13) or (znak=#10);
  if (lancuch = #13) or (lancuch=#10) or (lancuch=#13#10) or (lancuch=#10#13)
   then lancuch :='';
 end;{napis}
   *)
procedure Heap(var tref : TrefTyp;      {tablica wskaznikow na placki}
                 var SizeOfHeap : word);  {liczba plackow}

 var  blok, i : longword; progStep:single;
 HeapError : pointer;
 warstwa_nr :Word;
begin
 form1.PageControl3.ActivePageIndex:=0;
 form1.ProgressBar1.Visible:=true;
 progStep:=form1.ProgressBar1.Width/maxLbaBlok;
 form1.ProgressBar1.Position:=0;
 screen.Cursor:=-2;     Application.ProcessMessages;
 warstwa_nr:=0;
 HeapError :=@HeapServ;
 blok:=SizeOf(obs);                           //obs = array[0..bufor] of typ_skl;
 for i:= 0 to maxLbaBlok do tref[i]:= nil;   //typ_skl = smallInt; (pierwotne word; zmiana 20.06.05 aby można czytać Wav)
 repeat
  new(tref[warstwa_nr]);
  Inc(warstwa_nr);
  form1.ProgressBar1.Position:=round(warstwa_nr*progStep);  Application.ProcessMessages;
 until (tref[warstwa_nr-1]=nil) or (warstwa_nr>maxLbaBlok);

 ShowMessage(' Na stercie odłożono '+intToStr(warstwa_nr)+' bloków o rozmiarze po '+
          intToStr(blok)+ ' bajtów każdy'#13#10+' Heap zajmuje więc '+intToStr(warstwa_nr*blok)+' bajtów'#13#10+'i może pomieścić '+
         floatToStr(warstwa_nr*(blok/SizeOf(typ_skl)))+' danych');
 if tref[0]=nil then
  begin
   ShowMessage(#7'Za mało miejsca w pamięci aby uruchomić program');
   halt;
  end;
// writeln(cons,' Największy wolny blok w stercie ',MaxAvail);
 SizeOfHeap:=warstwa_nr-1;
 screen.Cursor:=0;
 form1.ProgressBar1.Visible:=false;
 Application.ProcessMessages;

end; {Heap}
                   //bufor,biez_koniec
procedure fromHeap(pocz:longint; var tref:trefTyp; var xr:TdbArr;
 grubosc:word; count,lba_danych:longWord;sklSt:word; out error_code:integer);
 var
     i,j,k,l : longWord;
 begin
  error_code:=0;
  i:=pocz div (grubosc+1);                   {numer placka}
  j:=pocz mod (grubosc+1);                   {numer w placku}
  for k:=pocz to pocz+count-1 do
   begin
    l:=-pocz+k;
    if pocz+l<lba_danych-1 then
     begin
      if j<=grubosc then
       begin
        xr[l]:=tref[i][j];
        j:=j+1;
       end{if}
      else                                   {przejsc do nastepnego placka}
      begin
       i:=i+1; j:=0;
       xr[l]:=tref[i][j];
       j:=j+1;
      end{else}
     end
    else xr[l]:=sklSt;
   end;{for}
   if pocz+count<lba_danych then error_code:=1 //schodzenie z danych
 end;{fromHeap}

procedure convert(Gain:integer;var xr:TdbArr; count:word;var ymin,ymax:realType);
{
konwersja wartosci 12-to bitowych z uwzglednieniem nastawy zakresu pomiaru
przetwornika a/d
}
var SklSt,i : word;  //UWAGA!sklSt powinna być raczej przekazywana przez zmienną, ze względu na korzystanie z niej na zewnątrz
        wsp : real;
 begin
  case Gain of 0..8,10,12,14 : SklSt:=2048 else SklSt:=0 end;
  case Gain of
   0..7,9 : wsp:=10.0;
        8 : wsp:=20;
    10,11 : wsp:=1.0;
    12,13 : wsp:=0.1;
    14,15 : wsp:=0.01;
  else wsp:=10
  end; {case wsp}
  wsp:=wsp/4095;
  for i := 0 to count-1 do
   xr[i] := (-SklSt+xr[i])*wsp;
  case Gain of
   0..7 : begin ymin:=- 5;     ymax:= 5    end;
      8 : begin ymin:=-10;     ymax:=10    end;
      9 : begin ymin:=  0;     ymax:=10    end;
     10 : begin ymin:= -0.5;   ymax:= 0.5  end;
     11 : begin ymin:=  0;     ymax:= 1    end;
     12 : begin ymin:= -0.05;  ymax:= 0.05 end;
     13 : begin ymin:=  0;     ymax:= 0.1  end;
     14 : begin ymin:= -0.01;  ymax:= 0.01 end;
     15 : begin ymin:=  0;     ymax:= 0.02 end;
  end;{case}
 end;{convert}
procedure convert_rel(Gain:integer; var xr:rAryType;count:word;
                      var ymin,ymax:realType);
{
konwersja wartosci 12-to bitowych do zakresu +-1 z uwzglednieniem
nastawy zakresu pomiaru przetwornika a/d
}
var SklSt,i : word;
        wsp : real;
 begin
  case Gain of 0..8,10,12,14 : SklSt:=2048 else SklSt:=0 end;
  case Gain of
   0..7,9 : wsp:=10.0;
        8 : wsp:=20;
    10,11 : wsp:=1.0;
    12,13 : wsp:=0.1;
    14,15 : wsp:=0.01;
  else wsp:=10
  end; {case wsp}
 case Gain of
  0..7 : wsp:=wsp/5;
   8,9 : wsp:=wsp/10;
    10 : wsp:=wsp/0.5;
    11 : wsp:=wsp/1;
    12 : wsp:=wsp/0.05;
    13 : wsp:=wsp/0.1;
    14 : wsp:=wsp/0.01;
    15 : wsp:=wsp/0.02;
 end;{case}
  wsp:=wsp/4095;
  for i := 0 to count-1 do
   xr[i] := (-SklSt+xr[i])*wsp;  //usunięto ^ ^
   ymin:=-1; ymax:=1;
  case Gain of
   0..8,10,12,14 : ymin:=- 1;
      9,11,13,15 : ymin:=  0;
  end;{case}
 end;{konvert_rel}
             (*
 procedure Music;
 begin
  sound(150); delay(50);
  sound(500);  delay(50);  sound(1150); delay(50); sound(950); delay(50);
  sound(300); delay(100); sound(444); delay(50); sound(489); delay(50);
  sound(533); delay(50);
  nosound;
 end;{music}
   *)
begin
// Writeln(cons,'2. Common');
 sqrCount:=high(sqrCount);
       auth:=#$6e#$61#$70#$69#$73#$61#$6e#$6f#$20#$77#$20#$6c#$75#$74#$79#$6d;
 auth:=auth+#$20#$31#$39#$39#$30#$72#$2e#$3b#$20#$41#$2e#$20#$50#$6c#$75#$63;
 auth:=auth+#$69#$6e#$73#$6b#$69#$2c#$20#$49#$6e#$73#$74#$79#$74#$75#$74#$20;
 auth:=auth+#$4a#$65#$7a#$79#$6b#$6f#$7a#$6e#$61#$77#$73#$74#$77#$61#$20#$55;
 auth:=auth+#$41#$4d#$2c#$20#$50#$6f#$7a#$6e#$61#$6e#$1a;
 //writeln(cons,auth);
 //FLUSH(cons);
// sklSt:=maxWord;
end.

http://www.chami.com/tips/delphi/111496D.html
Find out where your program is running from



See Also
Explore your documents, programs and URLs
How to create a console mode program
How to look for and handle command line parameters
Sometimes it's necessary to find out the path to the executable file of your program, in order to find out where to get the rest of the files from. In most cases, the current directory would be the directory where your programs are executed from, but this method would not work if your program path is listed in the PATH or if an user executes your program from another directory.

Here's how to get the directory where your programs is located:

  MessageDlg(
    'program path =  ' +
    ExtractFilePath( Application.ExeName )
    , mtInformation, [mbOk], 0 );
Listing #1 : Delphi code. Download exepath (0.23 KB).

