Fejléc

Delphi, pascal forráskódok, rutinok.
Példák, feladatmegoldások láncolt listára, rekord típusú tömbre,
buborék és beszúrásos rendezésre


Lekerekített sarkú komponens készítése
Használata: Oval(Memo1); , Oval(Edit1); stb....

 
procedure Oval(Control: TWinControl);
var
  R: TRect;
  Rgn: HRGN;
begin
  with Control do
  begin
    R := ClientRect;
    rgn := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom, 20, 20);
    Perform(EM_GETRECT, 0, lParam(@r));
    InflateRect(r, - 5, - 5);
    Perform(EM_SETRECTNP, 0, lParam(@r));
    SetWindowRgn(Handle, rgn, True);
    Invalidate;
  end;
end;

Képernyöfelbontás beállítása SetRes(1024,768), SetRes(1280, 1024)...
Csak szabványosat fogad el

 
procedure SetRes(XRes, YRes: DWord);
var lpDevMode : TDeviceMode;
begin
  EnumDisplaySettings(nil, 0, lpDevMode);
  lpDevMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
  lpDevMode.dmPelsWidth:=XRes;
  lpDevMode.dmPelsHeight:=YRes;
  ChangeDisplaySettings(lpDevMode, 0);
end;
procedure GetRes;
begin
Szeles:= GetSystemMetrics(SM_CXSCREEN);
Magas:= GetSystemMetrics(SM_CYSCREEN);
end;

Hangerö lekérdezése és beállítása (Wave)
Értékük 0 és 65535 között lehet

 
	
begin
  WaveOutGetDevCaps(WAVE_MAPPER, @WaveCaps, SizeOf(WaveCaps));
  if (WaveCaps.dwSupport and WAVECAPS_VOLUME) = WAVECAPS_VOLUME then begin
    WaveOutGetVolume(WAVE_MAPPER, @Volume);
    VolumeLeft  := LoWord(Volume);
    VolumeRight := HiWord(Volume);
  end
  else
    ShowMessage('Nem lehet a hangeröt lekérdezni !');
end;

procedure SetVolume;
begin
  WaveOutGetDevCaps(WAVE_MAPPER, @WaveCaps, SizeOf(WaveCaps));
  if (WaveCaps.dwSupport and WAVECAPS_VOLUME) = WAVECAPS_VOLUME then begin
    Volume := VolumeLeft or (VolumeRight shl 16);
    WaveOutSetVolume(WAVE_MAPPER, Volume);
  end
  else
    ShowMessage('Nem lehet a hangeröt beállítani !');
end;

Rekurzív file keresés - alkönyvtárakban is keres

 
procedure FindFiles(FilesList: TStringList; StartDir, FileMask: string);
var
  SR: TSearchRec;
  DirList: TStringList;
  IsFound: Boolean;
  i: integer;
begin
  if StartDir[length(StartDir)] <> '\' then
    StartDir := StartDir + '\';
  IsFound := FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;
  while IsFound do begin
    FilesList.Add(StartDir + SR.Name);
    IsFound := FindNext(SR) = 0;
  end;
  FindClose(SR);
  DirList := TStringList.Create;
  IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
  while IsFound do begin
    if ((SR.Attr and faDirectory) <> 0) and
         (SR.Name[1] <> '.') then
      DirList.Add(StartDir + SR.Name);
    IsFound := FindNext(SR) = 0;
  end;
  FindClose(SR);
  for i := 0 to DirList.Count - 1 do
    FindFiles(FilesList, DirList[i], FileMask);
  DirList.Free;
end;

Használata

 
procedure TForm1.Keres(Sender: TObject);
var
  FileList: TStringList;
begin
  FileList := TStringList.Create;
  FindFiles(FileList, 'c:\Mp3\', '*.Mp3');
.....
end; 

Írjon fájlkezelö programot a következö probléma megoldására:
Kérje be a felhasználótól '*' végjelig név, hallgatói átlag, lakhatási támogatás adatokat.
Számoljon ösztöndíjat mindegyes hallgatónak
a következök figyelembevételével:
0 <= átlag < 2.0 nem jár ösztöndíj
2.0 <= átlag < 3.1 10 000 Ft
3.1 <= átlag < 4.0 15 000 Ft
4.1 <= átlag <= 5.0 25 000 Ft
Írja ki a név, átlag, ösztöndíj, lakhatási támogatás és összesen (ösztöndíj+lakhatási)
adatokat egy szöveges állományba, melynek legyen 'hallgato.txt' a neve.
Majd olvassa vissza az adatokat, és írassa ki táblázatos formában.
Végezetül számolja ki, hogy átlagosan mennyi támogatást
(összesen, azaz ösztöndíj és lakhatási) kap egy hallgató.

 
program hallgato;
type hallgato = record
     nev : string[50];
     atlag : real;
     tamogatas : integer;
     osztondij :integer;
     teljes : integer;
     end;
var
  bevitel: hallgato;
  seged : string;
  hiba : integer;
  adatfile : Textfile;
  adatfilenev: string;
  hallgatoszam : integer;
  osszestamogatas : integer;
begin
  hallgatoszam := 0;
  osszestamogatas := 0;
  adatfilenev:='c:\hallgato.txt';
  {$I-}
  Assign(adatfile, adatfilenev);
  ReWrite(adatfile);
  repeat
    hiba := 1;
    WriteLn;
    Write('Név: ');
    ReadLn(bevitel.nev);
    if bevitel.nev= '*' then Break;
    while (hiba <> 0) or (bevitel.atlag > 5 ) do
    begin
      Write('Átlag: ');
      ReadLn(seged);
      Val(seged, bevitel.atlag, hiba);
    end;
    hiba := 1;
    while hiba <> 0 do
    begin
      Write('Lakhatási támogatás: ');
      ReadLn(seged);
      Val(seged, bevitel.tamogatas, hiba);
    end;
    hiba:=round(bevitel.atlag * 10);
    case hiba of
      0..20  : bevitel.osztondij := 0;
      21..30 : bevitel.osztondij := 10000;
      31..40 : bevitel.osztondij := 15000;
      41..50 : bevitel.osztondij := 25000;
     end;
    bevitel.teljes := bevitel.tamogatas + bevitel.osztondij;
    WriteLn(adatfile, bevitel.nev, #13, bevitel.atlag:1:1, #13, bevitel.tamogatas, #13, bevitel.osztondij, #13, bevitel.teljes);
  until bevitel.nev='*';
  Close(adatfile);
  Reset(adatfile);
  WriteLn;
  Write('Név                                ');
  Write('Átlag ');
  Write('Támogatás ');
  Write('Ösztöndíj   ');
  WriteLn('Öszesen   ');
  WriteLn('----------------------------------------------------------------------');
  while not eof(adatfile) do
  begin
    Readln(adatfile, bevitel.nev);
    Readln(adatfile, bevitel.atlag);
    Readln(adatfile, bevitel.tamogatas);
    Readln(adatfile, bevitel.osztondij);
    Readln(adatfile, bevitel.teljes);
    osszestamogatas := osszestamogatas + bevitel.teljes;
    WriteLn;
    inc(hallgatoszam);
    while Length(bevitel.nev) < 30 do bevitel.nev := bevitel.nev + ' ';
    Write(bevitel.nev:30,bevitel.atlag:10:1,bevitel.tamogatas:10,bevitel.osztondij:10,bevitel.teljes:10);
  end;
  Close(adatfile);
  {$I+}
  WriteLn;
  WriteLn;
  Writeln('Átlagos támogatás: ', osszestamogatas / hallgatoszam:10:0, ' / fö');
end.

  
Program adomany;

uses crt;

type rekord = record
        nev: string[50];
        datum: string[11];
        osszeg: integer;
     end;

var
        tomb: array[1..100] of rekord;
        elemszam: integer;
        i, j: integer;
        tmp, temp: rekord;
        s, dels: string;
        van: boolean;
        c: char;

procedure NevetRendez;
begin
  for i := 2 to elemszam - 1 do
  begin
    if (tomb[i].nev < tomb[i - 1].nev) and (tomb[i].osszeg = tomb[i - 1].osszeg) then
    begin
      tmp := tomb[i];
      j := i;
      repeat
        Dec(j);
        tomb[j + 1]:=tomb[j];
      until (j = 1) or (tomb[j - 1].nev <= tmp.nev);
      tomb[j]:=tmp;
    end;
  end;
end;

procedure Kiir;
var f : textfile;
begin
  Assign(f, 'C:\megoldasok\adomany\kimenet.txt');
  ReWrite(f);
  for i := 1 to elemszam - 1 do
  begin
    WriteLn(f, tomb[i].nev);
    WriteLn(f, tomb[i].datum);
    WriteLn(f, tomb[i].osszeg);
  end;
  Close(f);
end;

procedure Beolvas;
var f : textfile;
begin
  elemszam := 1;
  Assign(f, 'C:\megoldasok\adomany\bemenet.txt');
  Reset(f);
    ReadLn(f, tomb[elemszam].nev);
    ReadLn(f, tomb[elemszam].datum);
    ReadLn(f, tomb[elemszam].osszeg);
    Inc(elemszam);
  //Beolvasás közben rendezzük a tömböt
  while not eof(f) do
  begin
    ReadLn(f, tomb[elemszam].nev);
    ReadLn(f, tomb[elemszam].datum);
    ReadLn(f, tomb[elemszam].osszeg);
    for i := 2 to elemszam do
    begin
      if tomb[i].osszeg > tomb[i - 1].osszeg then
      begin
        tmp := tomb[i];
        j := i;
        repeat
          Dec(j);
          tomb[j + 1]:=tomb[j];
        until (j = 1) or (tomb[j - 1].osszeg >= tmp.osszeg);
        tomb[j]:=tmp;
      end;
    end;
  Inc(elemszam);
  end;
  Close(f);
  //Azonos befizetésűeket is rendezzük név szerint
  NevetRendez;
end;

procedure UjAdomanyozo;
begin
  Inc(elemszam);
  Write('Adományozó neve:     ');
  ReadLn(temp.nev);
  Write('Adomonyozás ideje:   ');
  ReadLn(temp.datum);
  Write('Adományozás összege: ');
  ReadLn(temp.osszeg);
  //Megkeressk az elem helyét
  for i := elemszam - 1 downto 1 do
  begin
    if temp.osszeg >= tomb[i].osszeg then j := i;
  end;

  for i := elemszam - 1 downto j + 1 do
  begin
    tomb[i] := tomb[i - 1];
  end;
  tomb[j] := temp;
  NevetRendez;
  WriteLn;
  for i := 1  to elemszam - 1 do
  begin
    WriteLn(tomb[i].nev);
    WriteLn(tomb[i].datum);
    WriteLn(tomb[i].osszeg);
  end;
  WriteLn;
  ReadLn;
end;

procedure AdomanyozoTorlese;
begin
  s := '';
  dels := '';
  ClrScr;
  for i := 1  to elemszam - 1 do
  begin
    WriteLn(tomb[i].nev);
    WriteLn(tomb[i].datum);
    WriteLn(tomb[i].osszeg);
  end;
  WriteLn;
  j := 0;
  Write('Írja be a törölni kivánt nevet: ');
  ReadLn(s);
  for i := 1 to elemszam  do
  begin
    if tomb[i].nev = s then
    begin
      j := j + 1;
      van:= True;
    end;
  end;
  if van = False then
  begin
    WriteLn('Nincs ilyen név !');
    ReadLn;
  end;
  if j > 1 then
  begin
    WriteLn('Több név is van');
    for i := 1 to elemszam do
    begin
      if tomb[i].nev = s then
      begin
        WriteLn(tomb[i].nev);
        WriteLn(tomb[i].datum);
      end;
    end;
    WriteLn;
    Write('Adja meg a születési dátumát a törölni kivánt személynek: ');
    ReadLn(dels);
    for i := 1 to elemszam do
    begin
      if (tomb[i].nev = s) and (tomb[i].datum = dels) then j := i;
    end;
    for i := j  to elemszam do
    begin
      tomb[i] := tomb[i + 1];
    end;
    Dec(elemszam);
    WriteLn;
    for i := 1  to elemszam - 1 do
    begin
      WriteLn(tomb[i].nev);
      WriteLn(tomb[i].datum);
      WriteLn(tomb[i].osszeg);
    end;
    WriteLn;
    ReadLn;
    Exit;
  end;
  if van then
  begin
    for i := 1 to elemszam do
    begin
      if tomb[i].nev = s then j := i;
    end;
    for i := j  to elemszam do
    begin
      tomb[i] := tomb[i + 1];
    end;
    Dec(elemszam);
  end;
  for i := 1  to elemszam - 1 do
  begin
    WriteLn(tomb[i].nev);
    WriteLn(tomb[i].datum);
    WriteLn(tomb[i].osszeg);
  end;
  WriteLn;
  ReadLn;
end;

begin
  Beolvas;
  repeat
    ClrScr;
    WriteLn('U - Új adományozó hozzáadása');
    WriteLn('T - Adományozó törlése');
    WriteLn('X - Kilépés a programból');
    c:= ReadKey;
    c:=UpCase(c);
    case c of
      'U': UjAdomanyozo;
      'T': AdomanyozoTorlese;
    end;
  until UpCase(c)= 'X';
  Kiir;
end.

  
Program utalas;

type rekord = record
        datum : string[16];
        osszeg : real;
        egyenleg: real;
        end;

var f: textfile;
    i, j, n, min, max: integer;
    s: string;
    c: char;
    temp: rekord;
    tomb: array[1..1000] of rekord;

begin
  //Beolvasás
  //A rendezés miatt a dátumot és az idöt összefüzzük
  //A számolás miatt az összeget elöjellel látjuk el

  Assign(f, 'c:\bemenet.txt');
  Reset(f);
  ReadLn(f, n);
  for i:= 1 to n do
  begin
    ReadLn(f, tomb[i].datum);
    ReadLn(f, s);
    tomb[i].datum:=tomb[i].datum+s;
    ReadLn(f, c);
    ReadLn(f, tomb[i].osszeg);
    if c = 'K' then tomb[i].osszeg := 0 - tomb[i].osszeg;
  end;
  Close(f);

  //Rendezés

  for i := 3 downto 1 do
  begin
    for j := 1 to i do
    begin
      if tomb[j].datum > tomb[j+1].datum then
      begin
        temp := tomb[j];
        tomb[j] := tomb[j+1];
        tomb[j+1] := temp;
      end;
    end;
  end;

  //Egyenleg számítás

  tomb[1].egyenleg := tomb[1].osszeg;
  for i := 2 to n do
  begin
    tomb[i].egyenleg := tomb[i-1].egyenleg + tomb[i].osszeg;
  end;

  //Minimumkiválasztás

  min := 1;
  for i := 1 to n do
  begin
    if tomb[i].egyenleg < tomb[min].egyenleg then min:= i;
  end;

  //Maximumkiválasztás

  max := 1;
  for i := 1 to n do
  begin
    if tomb[max].egyenleg < tomb[i].egyenleg then max:= i;
  end;

  //Értékek kiírása

  WriteLn('Minimum öszeg : ',tomb[min].egyenleg:10:2,' EUR');
  WriteLn('Maximum összeg: ',tomb[max].egyenleg:10:2, ' EUR');
  WriteLn('Záró egyenleg : ',tomb[n].egyenleg:10:2,' EUR');
  WriteLn;

  //Kirás file-ba és képernyöre
  //Szétszedjük a dátumot
  //A K-t és B-t az elöjel alapján megállapítjuk
  //Abszolut értéket írunk ki

  Assign(f, 'C:\kimenet.txt');
  ReWrite(f);
  WriteLn(f, n);
  for i := 1 to n do
  begin
    WriteLn(Copy(tomb[i].datum,1,11));
    WriteLn(Copy(tomb[i].datum,12,16));
    if tomb[i].osszeg < 0 then WriteLn('K') else WriteLn('B');
    WriteLn(Abs(tomb[i].osszeg):4:2);

    WriteLn(f, Copy(tomb[i].datum,1,11));
    WriteLn(f, Copy(tomb[i].datum,12,16));
    if tomb[i].osszeg < 0 then WriteLn(f, 'K') else WriteLn(f, 'B');
    WriteLn(f, Abs(tomb[i].osszeg):4:2);
  end;
  Close(f);

end.

  
Program penztar;

uses crt;

type PElem = ^Elem;

Elem = record
         nev : string[50];
         penztar : byte;
         kov : PElem;
       end;

var f : TextFile;
    uj, akt, elso, utolso : PElem;
    c : char;

//Beolvassa az adott file-böl az adatokat

procedure Beolvas;
begin
  Assign(f, 'C:\megoldasok\lancoltlista_penztar\bemenet.txt');
  Reset(f);
  while not eof(f) do
  begin
    new(uj);
    ReadLn(f,uj^.nev);
    ReadLn(f,uj^.penztar);
    if elso = nil then elso := uj else utolso^.kov := uj;
    utolso := uj;
  end;
  Close(f);
end;

//Képernyöre írja a láncolt lista elemeit

procedure Kiir;
begin
  akt := elso;
  if akt = nil then Exit;
  WriteLn;
  WriteLn('V rakoz˘k:');
  while akt <> nil do
  begin
    WriteLn(akt^.nev);
    WriteLn(akt^.penztar);
    akt := akt^.kov;
  end;
  WriteLn;
  WriteLn('Folytatáshoz nyomjon Entert !');
  ReadLn;
end;

//File-ba írja a láncolt lista elemeit

procedure FileKiir;
begin
  akt := elso;
  if akt = nil then Exit;
  Assign(f, 'C:\megoldasok\lancoltlista_penztar\kimenet.txt');
  ReWrite(f);
  akt := elso;
  while akt <> nil do
  begin
    WriteLn(f, akt^.nev);
    WriteLn(f, akt^.penztar);
    akt := akt^.kov;
  end;
  Close(f);
end;

//Megkeresi a legkisebb pénztár számot és visszaadja

function MinSorszam : integer;
begin
  akt := elso;
  if akt = nil then Exit;
  MinSorszam := akt^.penztar;
  while akt <> nil do
  begin
    if MinSorszam > akt^.penztar then MinSorszam := akt^.penztar;
    akt := akt^.kov;
  end;
end;

//Megkeresi a legnagyobb pénztár számot és visszaadja

function MaxSorszam : integer;
begin
  akt := elso;
  if akt = nil then Exit;
  MaxSorszam := akt^.penztar;
  while akt <> nil do
  begin
    if MaxSorszam < akt^.penztar then MaxSorszam := akt^.penztar;
    akt := akt^.kov;
  end;
end;

//Bekeri az adatokat és utolsónak hozzáfűzi a listához

procedure UjKliens;
begin
  new(uj);
  Write('Új kliens neve:  ');
  ReadLn(uj^.nev);
  Write('Pénztár sorszám: ');
  ReadLn(uj^.penztar);
  if elso = nil then elso := uj else utolso^.kov := uj;
  utolso := uj;
  Kiir;
end;

procedure Kiszolgalas;
var r : integer;
    van : boolean;
begin
  van := False;
  akt := elso;
  if akt = nil then
  begin
    WriteLn('Nincsenek várakozók !');
    WriteLn;
    WriteLn('Folytatáshoz nyomjon Entert !');
    ReadLn;
    Exit;
  end;
  repeat //Olyan véletlenszámot generál ami a pénztárak számának megfelel
    r := 0;
    Randomize;
    while r < MinSorszam do
      r := Random(MaxSorszam) + 1;
    akt := elso;
    while akt <> nil do
    begin
      if akt^.penztar = r  then
      begin
        van := True; //Kiirja a megfelelö kliens nevét
        WriteLn('Pénztárhoz szólítva: ');
        WriteLn(akt^.nev);
        WriteLn(akt^.penztar);
        Break;
      end;
      akt := akt^.kov;
    end;
  until van;
  akt := elso;
  if akt^.kov = nil then
  begin
    WriteLn;
    WriteLn('Folytatáshoz nyomjon Entert !');
    ReadLn;
  end;
  akt := elso; //Törli a listából
  while akt^.penztar <> r do akt := akt^.kov;
  if akt = elso then elso := elso^.kov else
  begin
    akt := elso;
    while (akt^.kov^.penztar <> r ) do
    akt := akt^.kov;
    akt^.kov := akt^.kov^.kov;
    if akt^.kov = nil then utolso := akt;
  end;
  Kiir;
end;

procedure Felszabadit;
begin
  akt := elso;
  while akt <> nil do
  begin
    elso := akt^.kov;
    Dispose(akt);
    akt := elso;
  end;
end;

begin
  Beolvas;
  repeat
    ClrScr;
    WriteLn('U - Új kliens érkezett');
    WriteLn('K - Kliens kiszolgálása');
    WriteLn('X - Kilépés a programból');
    c:= ReadKey;
    c:=UpCase(c);
    case c of
      'U': UjKliens;
      'K': Kiszolgalas;
    end;
  until UpCase(c)= 'X';
  FileKiir;
  Felszabadit;
end.

program Adomanyozas;

type rekord = record
        nev : string[50];
        szdatum, adomdatum : string[11];
        osszeg : real;
     end;

var
  tomb : array[1..300] of rekord;
  tmptomb : array[1..300] of rekord;
  tmp : rekord;
  i, n, tmpelemszam, elemszam : integer;

procedure Kiir;
var f : textfile;
begin
  Assign(f, 'D:\Pascal\kimenet.txt');
  ReWrite(f);
  WriteLn(f, elemszam);
  for i := 1 to elemszam do
  begin
    WriteLn(f, tomb[i].nev);
    WriteLn(f, tomb[i].szdatum);
    WriteLn(f, tomb[i].adomdatum);
    WriteLn(f, tomb[i].osszeg:2:2);
  end;
  Close(f);
end;

procedure Beolvas;
var f : textfile;
begin
  Assign(f, 'D:\Pascal\bemenet.txt');
  Reset(f);
  ReadLn(f, elemszam);
  for i := 1 to elemszam do
  begin
    ReadLn(f, tomb[i].nev);
    ReadLn(f, tomb[i].szdatum);
    ReadLn(f, tomb[i].adomdatum);
    ReadLn(f, tomb[i].osszeg);
  end;
  Close(f);
end;

procedure Keres;
begin
  tmpelemszam := elemszam;
  for i := 1 to tmpelemszam - 1 do
  begin
    for n := i + 1 to tmpelemszam do
    begin
      if ((tomb[i].nev = tomb[n].nev) and (tomb[i].szdatum = tomb[n].szdatum)) then
      begin
        tomb[i].osszeg := tomb[i].osszeg + tomb[n].osszeg;
        tomb[i].adomdatum := tomb[n].adomdatum;
        Dec(elemszam);
        tomb[n].nev := '';
      end;
    end;
  end;
  n := 1;
  for i := 1 to 300 do
  begin
    if tomb[i].nev <> '' then
    begin
      tmptomb[n] := tomb[i];
      Inc(n);
    end;
  end;
  tomb := tmptomb;
end;

procedure MaxSort(tol, ig : integer);
begin
  n := tol;
  for i := tol to ig do
  if tomb[i].osszeg > tomb[n].osszeg then n := i;
  tmp := tomb[tol];
  tomb[tol] := tomb[n];
  tomb[n] := tmp;
  Inc(tol);
  if (ig - tol) > 0 then MaxSort(tol, ig);
end;

begin
  Beolvas;
  Keres;
  MaxSort(1, 3);
  Kiir;
  ReadLn;
end.

A feltöltések folyamatosak lesznek, ahogy az idöm engedi.......


Mgr.Végh László: Delphi jegyzet 1.  


Mgr.Végh László: Delphi jegyzet 2.  


Mgr.Végh László: Delphi jegyzet 1 feladatmegoldások.  


Mgr.Végh László: Delphi jegyzet 2 feladatmegoldások.  


Dr. Szabó László: Delphi 2.0-ról röviden.  


Turbó Pascal 6.0 magyar nyelvü helppel  


Copyright © 2013 Simkó Lajos - Minden jog fenntartva. Módosítva: 2015. április