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; |
|
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; |
|
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; |
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; |
procedure TForm1.Keres(Sender: TObject); var FileList: TStringList; begin FileList := TStringList.Create; FindFiles(FileList, 'c:\Mp3\', '*.Mp3'); ..... end; |
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); //Megkeressk 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. |