unit TrimStr;
interface
Const Space = #$20;
function LTrim(Str: String): String;
function RTrim(Str: String): String;
function Trim(Str: String): String;
implementation
function LTrim(Str: String): String;
var len: Byte absolute Str; i: Integer;
begin
i := 1;
while (i < = len) and (Str[i] = Space) do Inc(i); LTrim := Copy(Str,i,len-i+1)
end {LTrim};
function RTrim(Str: String): String;
var len: Byte absolute Str;
begin
while (Str[len] = Space) do Dec(len); RTrim := Str
end {RTrim};
function Trim(Str: String): String;
begin
Trim := LTrim(RTrim(Str))
end {Trim};
end.
{To determine if the character is a digit.}
function IsDigit(ch: char): boolean;
begin
Result := ch in ['0'..'9'];
end;
{To determine if the character is an uppercase letter.}
function IsUpper(ch: char): boolean;
begin
Result := ch in ['A'..'Z'];
end;
{To determine if the character is an lowercase letter.}
function IsLower(ch: char): boolean;
begin
Result := ch in ['a'..'z'];
end;
{Changes a character to an uppercase letter.}
function ToUpper(ch: char): char;
begin
Result := chr(ord(ch) and $DF);
end;
{Changes a character to a lowercase letter.}
function ToLower(ch: char): char;
begin
Result := chr(ord(ch) or $20);
end;
{ Capitalizes first letter of every word in s }
function Proper(const s: string): string;
var i: Integer; CapitalizeNextLetter: Boolean;
begin
Result := LowerCase(s); CapitalizeNextLetter := True;
for i := 1 to Length(Result) do begin
if CapitalizeNextLetter and IsLower(Result[i]) then
Result[i] := ToUpper(Result[i]); CapitalizeNextLetter := Result[i] = ' ';
end; end;
{Supresses trailing blanks in a string.}
function TrimRight(const s: string): string;
var i: integer;
begin
i := Length(s);
while (I > 0) and (s[i] < = ' ') do Dec(i); Result := Copy(s, 1, i);
end;
{Removes the leading spaces from a string.}
function TrimLeft(const S: string): string;
var I, L: Integer;
begin
L := Length(S); I := 1;
while (I < = L) and (S[I] < = ' ') do Inc(I);
Result := Copy(S, I, Maxint);
end;
{ Removes leading and trailing whitespace from s);
function Trim(const S: string): string;
var I, L: Integer;
begin
L := Length(S); I := 1;
while (I < = L) and (S[I] < = ' ') do Inc(I);
if I > L then Result := '' else begin
while S[L] < = ' ' do Dec(L); Result := Copy(S, I, L - I + 1);
end; end;
Jeżeli potrzebna jest funkcja, która dopuszcza jedynie wprowadzanie łańcuchów do pewnej długości to :
function padleft(S: String; N: Integer): String;
begin
While Length(S) < N do Insert(' ',S,1); Result:=S
end;
function padright(S: String; N: Integer): String;
begin
While Length(S) < N do Insert(' ',S,Length(S)+1); Result:=S
end;
Poniższa procedura daje możliwość dotarcia do dowolnego znaku w łańcuchów pola Memo i sprawdza jednocześnie te znaki. Linie znaków w Memo mają właściwość TStringList; ich analiza następuje w pamięci tymczasowej Temp.
procedure TForm1.ManipulateMemo( TheMemo : TMemo ; SomeChar, OtherChar : char ) ;
var i : word ; j : byte ;
begin
{ StringLists are indexed from 0 }
for i := 0 to TheMemo.Lines.Count - 1 do begin
Temp := TheMemo.Lines[i] ; for j := 1 to Length( Temp ) do
if Temp[j] = SomeChar then { or whatever kind of character by }
Temp[j] := OtherChar ; { character manipulations you need }
TheMemo.Lines.Insert( i, Temp ) ; { insert modified line at current pos}
TheMemo.Lines.Delete( i + 1 ) ; { remove old version of line }
end ; end ;
Wyprowadzenie danych do PChar:
function TBWF.TMemoFieldSize(Memo: TMemoField): Word;
var BS: TBlobStreeam;
begin
BS := TBlobStream.Create(TMemoField(Memo), bmRead);
Result := BS.Size; BS.Free;
end;
Stworzenie PChar z pola zakończonego zerem (Size + 1):
procedure TBWF.TMemoFieldToPChar(Memo: TMemoField; var Buffer: PChar; Size: Word);
var BS: TBlobStream;
begin
try begin
BS := TBlobStream.Create(TMemoField(Memo), bmRead);
FillChar(Buffer^, Size, #0); BS.Read(Buffer^, Size);
end; finally BS.Free; end;
end;
function GrabMemoFieldAsPChar(TheField : TMemoField): PChar;
begin
GetMem(Result, TheField.Size + 1);
FillChar(Result^, TheField.Size + 1, #0);
with TBlobStream.Create(TheField, bmRead) do begin
Read(Result^, TheField.Size); Free;
end; end;
To łatwe sposoby aby z łańcucha np. 489,356,456 usunąć przecinki aby np. potem zastosować funkcjęStrToInt.
I. wariant:
var p : integer
begin
repeat p := pos(',',str); if p > 0 then delete(str,p,1); until p=0;
end;
II. wariant:
function stripped(stripchar : char, str : string) : string;
var tmpstr : string; { can't modify a value parameter and }
{ may not want to directly change the source }
begin
tmpstr := str; while pos(stripchar, tmpstr) > 0 do
delete(tmpstr, pos(stripchar, tmpstr), 1); stripped := tmpstr;
end;
I jego użycie: Edit2.Text := stripped(',', Edit1.Text);
III. wariant:
Function StripStr(S : String) : String;
Var bI : Byte;
Begin
bI:=1; While (bI length( s ) ) then
move( S[x+1], S[x], length( S ) - succ(x) );
(* można też użyć "delete( S, x, 1 );" instead of the above move() *)
dec( byte( s[0] ) ); end else inc( x ); end;
end;
IV. wariant:
For I:= Length(S) downto 1 do begin
if S[I] = ',' then delete(S,I,1)
end
unit GlbFuncs;
interface
function LTrim(sS : string) : string;
function RTrim(sS : string) : string;
function Trim(sS : string) : string;
implementation
function LTrim(sS : string) : string;
var iX, iLen : integer;
begin
iLen := Length(sS); if iLen > 0 then begin
iX := 1; while Copy(sS,iX,1) = ' ' do iX := iX + 1;
LTrim := Copy(sS,iX,iLen-(iX-1));
end else LTrim := sS;
end;
function RTrim(sS : string) : string;
var iX, iLen : integer;
begin
iLen := Length(sS); if iLen > 0 then begin
iX := iLen; while Copy(sS,iX,1) = ' ' do iX := iX - 1;
RTrim := Copy(sS,0,iX);
end else RTrim := sS;
end;
function Trim(sS : string) : string;
begin
Trim := LTrim(RTrim(sS));
end;
end.
Warianit II:
unit TrimStr; {$B-}
{ LTrim() - usuwa wszystkie spacje z lewej strony stringa
RTrim() - usuwa z prawej ....
Trim() - usuwa z lewej i prawej - wszystkie
RightStr() - bierze pewną ich ilość z prawej....
LeftStr() - bierze pewną ilość z lewej
MidStr() - i to samo ale ze środka }
interface
Const Space = #$20;
function LTrim(Const Str: String): String;
function RTrim(Str: String): String;
function Trim(Str: String): String;
function RightStr(Const Str: String; Size: Word): String;
function LeftStr(Const Str: String; Size: Word): String;
function MidStr(Const Str: String; Size: Word): String;
implementation
function LTrim(Const Str: String): String;
var len: Byte absolute Str; i: Integer;
begin
i := 1; while (i < = len) and (Str[i] = Space) do Inc(i); LTrim := Copy(Str,i,len)
end {LTrim};
function RTrim(Str: String): String;
var len: Byte absolute Str;
begin
while (Str[len] = Space) do Dec(len); RTrim := Str
end {RTrim};
function Trim(Str: String): String;
begin
Trim := LTrim(RTrim(Str))
end {Trim};
function RightStr(Const Str: String; Size: Word): String;
var len: Byte absolute Str;
begin
if Size > len then Size := len; RightStr := Copy(Str,len-Size+1,Size)
end {RightStr};
function LeftStr(Const Str: String; Size: Word): String;
begin
LeftStr := Copy(Str,1,Size)
end {LeftStr};
function MidStr(Const Str: String; Size: Word): String;
var len: Byte absolute Str;
begin
if Size > len then Size := len;
MidStr := Copy(Str,((len - Size) div 2)+1,Size)
end {MidStr};
end.
To inaczej - pisanie wspak - od tyłu, np. "Adam" da na wyjściu funkcji "madA". Można to wykonać przy pomocy jednej z ponizszych funkcji.
Wersja 1:
function ReverseString(s: string): string;
var i: integer;
begin
Result := ''; if Trim(s) < > '' then
for i := Length(s) downto 1 do Result := Result + s[i];
end;
Wersja 2:
function ReverseString(s: string): string;
var i: integer; c: char;
begin
if s < > '' then for i := 1 to Length(s) div 2 do
begin
c := s[i]; s[i] := s[Length(s) + 1 - i]; s[Length(s) + 1 - i] := c; end;
Result := s;
end;
Wersja 3:
function ReverseString1(const s: string): string;
var i, len: Integer;
begin
len := Length(s); SetLength(Result, len);
for i := len downto 1 do
begin
Result[len - i + 1] := s[i]; end;
end;
Wersja 4 autor Ido Kanner :
function ReverseString2(const Str: string): string;
var ch: Char; i, Size: Integer;
begin
Result := Str; Size := Length(Result); if (Size >= 2) then // 2 lub więcej znaków
begin
for i := 1 to (Size div 2) do
begin
ch := Result[i]; Result[i] := Result[Size - (i - 1)]; Result[Size - (i - 1)] := ch;
end end; end;
Wersja 5 autor Rudy Velthuis :
function ReverseString3(S: string): string;
var P, Q: PChar; C: Char;
begin
Result := S; if Length(Result) = 0 then Exit; P := PChar(Result);
Q := P + Length(Result) - 1; while P < Q do
begin
C := P^; P^ := Q^; Q^ := C; Inc(P); Dec(Q); end;
end;
Wersja 6 autor Rudy Velthuis:
procedure ReverseString4(var S: string);
var P, Q: PChar; C: Char;
begin
if Length(S) = 0 then Exit; P := PChar(S); Q := P + Length(S) - 1;
while P < Q do
begin
C := P^; P^ := Q^; Q^ := C; Inc(P); Dec(Q); end;
end;
//Wynikiem jest wartość true, jeśli ciąg wejściowy znaków jest właściwy.
Oznaczenia:
Rej - tryb flagi
jeśli Rej: = true, to Conf - ciąg zawiera niedozwolone znaki
jeśli Rej: = false, to Conf - ciąg poprawnych znaków
Input - ciąg wejściowy
function ConformStr(Input, Conf: string; Rej: boolean): boolean;
var i: integer;
begin
result := true; if Rej then begin
for i := 1 to length(Conf) do begin
if pos(Conf[i], Input) < > 0 then
begin
result := false; break; end end;
end else begin
for i := 1 to length(Input) do begin
if pos(Input[i], Conf) = 0 then begin
result := false; break; end; end; end;
end;
//przykład użycia:
s :='Witaj';
if not ConformStr(s, '0123456789') then s := Strtst(s, '0123456789');
//jak wpisze poprawnie ciąg znakow 0 do 9 to zobaczy napis 'Witaj' albo (zmień sobie) ruszy program
Pola typu TBlobField ma metod, które pozwalają dane mają być przechowywane w plikach zawarte lub
w Stream ... W pierwszym przypadku (pliki), kod będzie coś takiego:
TBlobField(SuaTabela.FieldByName('SeuCampo')).LoadFromFile('NomedoArquivo');
W drugim przypadku może być przykład z TRichEdit:
var Stream : TMemoryStream;
begin
Stream := TMemoryStream.Create;
try
RichEdit1.Lines.SaveToStream(Stream);
Stream.Seek(0,soFromBeginning);
TBlobField(SuaTabela.FieldByName('SeuCampo')).LoadFromStream(Stream);
finally Stream.Free;
end; end;
Oba przykłady zakładają, że tabela już ma być w trybie edycji lub wstawiania.
Funkcja poniżej przyjmuje jako parametr obiekt typu TStrings i drukowanie każdej linii w drukarkę
domyślną. Jako parametr typu obiektu jest TStrings, funkcja ta działa z wszelkiego rodzaju składników, które
pochodzą od TStrings właściwości (np. TDBMemo, TListBox, TMemo, TOutline, itp.).
uses Printers;
procedure PrintStrings(Strings: TStrings);
var Prn: TextFile; i: word;
begin
AssignPrn(Prn); try Rewrite(Prn); try for i := 0 to Strings.Count - 1 do
writeln(Prn, Strings.Strings[i]); finally CloseFile(Prn);
end; except
on EInOutError do
MessageDlg(' Błąd drukowania tekstu.', mtError, [mbOk], 0);
end; end;
Aby wydrukować zawartość TStringList, należy użyć następującej składni:
PrintStrings(Listbox1.Items);
procedure scandir(startdir: string; mask:string; list:tstringlist; subdir:boolean=true);
var searchrec : tsearchrec;
begin if mask = '' then mask := '*.*';
if startdir[length(startdir)] < > '\' then startdir := startdir + '\';
if findfirst(startdir+'*.*', faanyfile, searchrec) = 0 then
begin
repeat application.processmessages;
if (searchrec.attr and fadirectory) < > fadirectory then
begin
if matchesmask(searchrec.name,mask) then
list.add(startdir + searchrec.name);
end else
if (searchrec.name < > '..') and (searchrec.name < > '.') then
if subdir then scandir(startdir + searchrec.name + '\',mask,list);
until findnext(searchrec) < > 0; findclose(searchrec);
end; end;
type psrec=^tsearchrec;
function datecompare(item1, item2: pointer): integer;
begin
if psrec(item1)^.time > psrec(item2)^.time then result:=1 else
if psrec(item1)^.time=psrec(item2)^.time then result:=0 else
result:=-1;
end;
procedure tform1.button1click(sender: tobject);
var i:integer; srlist:tlist; sr:tsearchrec; psr:psrec;
begin
srlist:=tlist.create; if f srlist.count > 1 then srlist.sort(datecompare);
for i:=0 to srlist.count-1 do memo1.lines.add(psrec(srlist.items[i])^.name+' '+
datetimetostr(filedatetodatetime(psrec(srlist.items[i])^.time)));
srlist.free;
end;
procedure filecopy(const sourcefilename, targetfilename: string);
var s,t : tfilestream;
begin
s := tfilestream.create(sourcefilename, fmopenread );
try t := tfilestream.create(targetfilename, fmopenwrite or fmcreate);
try t.copyfrom(s, s.size ) ; filesetdate(t.handle, filegetdate(s.handle));
finally t.free; end;
finally s.free; end;
end;
uses psapi, tlhelp32;
procedure createwin9xprocesslist(list: tstringlist);
var hsnapshot: thandle; procinfo: tprocessentry32;
begin
if list = nil then exit;
hsnapshot := createtoolhelp32snapshot(th32cs_snapprocess, 0);
if (hsnapshot < > thandle(-1)) then
begin
procinfo.dwsize := sizeof(procinfo);
if (process32first(hsnapshot, procinfo)) then
begin
list.add(procinfo.szexefile);
while (process32next(hsnapshot, procinfo)) do
list.add(procinfo.szexefile);
end;
closehandle(hsnapshot); end;
end;
procedure createwinntprocesslist(list: tstringlist);
var pidarray: array [0..1023] of dword; cb: dword; i: integer; proccount: integer;
hmod: hmodule; hprocess: thandle; modulename: array [0..300] of char;
begin
if list = nil then exit; enumprocesses(@pidarray, sizeof(pidarray), cb);
proccount := cb div sizeof(dword); for i := 0 to proccount - 1 do
begin
hprocess := openprocess(process_query_information or process_vm_read,
false, pidarray[i]);
if (hprocess < > 0) then
begin
enumprocessmodules(hprocess, @hmod, sizeof(hmod), cb);
getmodulefilenameex(hprocess, hmod, modulename, sizeof(modulename));
list.add(modulename); closehandle(hprocess); end; end;
end;
procedure getprocesslist(var list: tstringlist);
var ovi: tosversioninfo;
begin
if list = nil then exit; ovi.dwosversioninfosize := sizeof(tosversioninfo);
getversionex(ovi); case ovi.dwplatformid of
ver_platform_win32_windows: createwin9xprocesslist(list);
ver_platform_win32_nt: createwinntprocesslist(list); end
end;
function exe_running(filename: string; bfullpath: boolean): boolean;
var i: integer; myproclist: tstringlist;
begin
myproclist := tstringlist.create;
try getprocesslist(myproclist); result := false;
if myproclist = nil then exit; for i := 0 to myproclist.count - 1 do
begin
if not bfullpath then begin
if comparetext(extractfilename(myproclist.strings[i]), filename) = 0 then
result := true
end else if comparetext(myproclist.strings[i], filename) = 0 then result := true;
if result then break; end;
finally myproclist.free; end;
end;
//przykład 1 - czy taki plik EXE jest aktywny?
procedure tform1.button1click(sender: tobject);
begin
if exe_running('notepad.exe', false) then showmessage('exe is running')
else showmessage('exe is not running');
end;
// przykład 2 - lista aktywnych plikow EXE
procedure tform1.button3click(sender: tobject);
var i: integer; myproclist: tstringlist;
begin
myproclist := tstringlist.create;
try getprocesslist(myproclist); if myproclist = nil then exit;
for i := 0 to myproclist.count - 1 do listbox1.items.add(myproclist.strings[i]);
finally myproclist.free; end;
end;
//Przenosi element w górę
procedure LbMoveItemUp(AListBox: TListBox);
var CurrIndex: Integer;
begin
with AListBox do if ItemIndex > 0 then
begin
CurrIndex := ItemIndex; Items.Move(ItemIndex, (CurrIndex - 1));
ItemIndex := CurrIndex - 1; end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
LbMoveItemUp(ListBox1);
end;
// Przenosi element w dól
procedure LbMoveItemDown(AListBox: TListBox);
var CurrIndex, LastIndex: Integer;
begin
with AListBox do
begin
CurrIndex := ItemIndex; LastIndex := Items.Count; if ItemIndex < > -1 then
begin
if CurrIndex + 1 < LastIndex then
begin
Items.Move(ItemIndex, (CurrIndex + 1)); ItemIndex := CurrIndex + 1;
end; end; end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
LbMoveItemDown(ListBox1);
end;
procedure TForm1.Button1Click(Sender: TObject);
const PIXEL_WIDTH = 200;
begin
ComboBox1.Perform(CB_SETDROPPEDWIDTH, PIXEL_WIDTH, 0);
end;
{rozwijana lista przyjmie rozmiary najdłuższego łańcucha.}
procedure TForm1.Button2Click(Sender: TObject);
var i, ItemWidth: Integer;
begin
ItemWidth := 0; with Combobox1 do
begin
for i := 0 to Items.Count - 1 do
if (Form1.Canvas.TextWidth(Items[i]) < > ItemWidth) then
ItemWidth := Form1.Canvas.TextWidth((Items[i])) + 20;
Perform(CB_SETDROPPEDWIDTH, ItemWidth, 0);
end; end;
{ ładowanie milionów rekordów tak może być powolne }
procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
StringList.Clear; with SourceTable do
begin
Open; DisableControls; try while not EOF do
begin
StringList.Add(FieldByName('OriginalData').AsString); Next; end;
finally EnableControls; Close; end; end;
end;
{ Tak jest dużo dużo szybciej }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
with CacheTable do
begin
Open; try StringList.Text := FieldByName('Data').AsString;
finally Close; end; end;
end;
Klasy TStrings i komponenty TTreeview / TListView pozwalają na dodanie dodatkowego obiektu do
łańcucha znaków.
type TMyRecord = record
id: Integer;
Name: string;
{...}
end;
PMyRecord = ^TMyRecord;
{...}
{ ten przykład bazuje na komponencie Listview }
procedure Form1.Form1Create(Sender: TObject)
var i: Integer; pRec: PMyRecord;
begin
for i := 0 to 10 do
begin
new(pRec); pRec.id := i; pRec.Name := 'Entry' + IntToStr(i);
{...}
ListView1.AddItem('Entry' + IntToStr(i), Pointer(pRec));
end; end;
{ to do pobrania przechowywanych rekordów: }
procedure Form1.ListView1Click(Sender: TObject);
var i: Integer; xRec: TMyRec;
begin
for i := 0 to Listview1.Count - 1 do if ListView1.Selected[i] then
begin
xRec := PMyRecord(ListView1.Items.Objects[i])^;
ShowMessage(Format('Record #%d Name: %s', [xRec.id, xRec.Name]));
end; end;
{ w końcu zwolnij przydzieloną pamięć }
procedure Form1.FormClose(Sender: TObject);
var i: Integer;
begin
for i := 0 to ListView1.Count - 1 do
if ListView1.Items.Objects[i] < > nil then
Dispose(ListView1.Items.Objects[i]);
end;
unit dlist3_;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Button1: TButton;
Button2: TButton;
Label3: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure Button3Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
type TPStudent = ^TStudent; //wskaźnik do TStudent
TStudent = record
f_name: string[20]; // Nazwisko
l_name: string[20]; // Imię
next: TPStudent; // następny element listy
end;
var head: TPStudent; //poczatek (nagłówek) listy
procedure TForm1.Button1Click(Sender: TObject);
var
node: TPStudent; // nowy węzeł listy
curr: TPStudent; // aktualny węzeł (pozycja) listy
pre: TPStudent; // poprzedni w odniesieniu do aktualnego ...
begin
new(node); // tworzy nowy element listy
node^.f_name := Edit1.Text; node^.l_name := Edit2.Text;
// dodaje węzeł do listy po uprzednim znalezieniu miejsca na stronie
curr := head; pre := nil;
while (curr < > nil) and (node.f_name > curr^.f_name) do
begin
//wprowadzona wartość jest większa niż obecnie
pre := curr; curr := curr^.next; // do kolejnego węzła
end;
if pre = nil then begin // nowy węzeł na początek listy
node^.next := head; head := node;
end else begin // nowy węzeł po pre, przed curr
node^.next := pre^.next; pre^.next := node; end;
Edit1.text := '' ; Edit2.text := ''; Edit1.SetFocus;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
curr: TPStudent; // bieżący element listy
n: integer; // liczba elementów listy
st: string; // początek tego łańcucha listy
begin
n := 0; st := ''; curr := head; while curr < > nil do
begin
n := n + 1; st := st + curr^.f_name + ' ' + curr^.l_name + #13; curr := curr^.next;
end;
if n < > 0 then ShowMessage('Lista:' + #13 + st)
else ShowMessage('Lista nie ma elementów.');
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
head := nil;
end;
// klik na przycisku usuń
procedure TForm1.Button3Click(Sender: TObject);
var curr: TPStudent; pre: TPStudent; found: boolean; // TRUE - czyli taki węzeł jest na liście
begin
if head = nil then
begin
MessageDlg('Lista jest pusta!', mtError, [mbOk], 0); Exit; end;
curr := head; // aktualny węzeł jest pierwszym
pre := nil; // następnego już nie ma
found := FALSE;
// szukanie węzła, którego trzeba zniszczyć
while (curr < > nil) and (not found) do
begin
if (curr^.f_name = Edit1.Text) and (curr^.l_name = Edit2.Text)
then found := TRUE //znaleziony.....
else begin // do następnego....
pre := curr; curr := curr^.next; end; end;
if found then
begin // szukany węzeł znaleziony
if MessageDlg('Węzeł zostanie usuniety z listy!', mtWarning, [mbOk, mbCancel], 0) < > mrYes
then Exit;
if pre = nil // niszczymy węzeł
then head := curr^.next //jeżeli jest również pierwszym...
else pre^.next := curr.next; Dispose(curr);
MessageDlg('Węzeł' + #13 + 'Imię:' + Edit1.Text + #13 + 'Nazwisko:' + Edit2.Text + #13 +
'usunięty z listy.', mtInformation, [mbOk], 0);
end else // jak takiego węzła nie ma to
MessageDlg('Węzeł' + #13 + 'Imię:' + Edit1.Text + #13 + 'Nazwisko:' + Edit2.Text + #13 +
'w spisie nie figuruje.', mtError, [mbOk], 0);
Edit1.Text := ''; Edit1.Text := ''; Edit1.SetFocus;
end;
end.
Za pomocą - StringList1.AddObject ("Nazwa listy", TStringList.Create) - można utworzyć TStringList,
który zawiera nazwę obiektu i sam obiekt TStringList. Ponieważ Delphi nie usuwa tych obiektów. Musisz
zadbać o to sam. Dostęp do powiązanych stringlist odbywa się poprzez zmienną:
TempStringList: = TStringList (StringList1.Objects [index]);
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, StdCtrls;
type TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private { Private declarations }
public { Public declarations }
StringList1, TempStringList: TStringList;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
StringList1 := TStringList.Create; StringList1.AddObject('Imię', TSTringList.Create);
TempStringList := TStringList(StringList1.Objects[0]);
TempStringList.Add('Witojcie kumie'); Label1.Caption := TempStringList[0];
end;
procedure TForm1.FormDestroy(Sender: TObject);//usuwamy objekt
var i: Longint;
begin
for i := 0 to StringList1.Count - 1 do
begin
TempStringList := TStringList(StringList1.Objects[i]); TempStringList.Free; end;
end;
end.
type PSRec=^TSearchRec;
function DateCompare(Item1, Item2: Pointer): Integer;
begin
if PSRec(Item1)^.Time > PSRec(Item2)^.Time then Result:=1 else
if PSRec(Item1)^.Time=PSRec(Item2)^.Time then Result:=0 else
Result:=-1;
end;
procedure TForm1.Button1Click(Sender: TObject);
vari: Integer; SRList:TList; SR:TSearchRec; PSR:PSRec;
begin
SRList:=TList.Create; if F SRList.Count > 1 then SRList.Sort(DateCompare);
for i:=0 to SRList.Count-1 do
Memo1.Lines.Add(PSRec(SRList.Items[i])^.Name+' '+
DateTimeToStr(FileDateToDateTime(PSRec(SRList.Items[i])^.Time)));
SRList.Free;
end;
Wariant 1:
procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
const oldidx : Longint = -1;
var idx : Longint;
begin
with Sender as TListBox do
begin
idx := ItemAtPos(Point(x,y),True); if (idx < 0) or (idx = oldidx) then Exit;
Application.ProcessMessages; Application.CancelHint;
oldidx := idx; Hint := '';
if Canvas.TextWidth(Items[idx]) > Width - 4 then Hint:=Items[idx]; end;
end;
Wariant 2:
procedure TfmDWMain.lbSearchMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var ItemNum: Integer;
begin
ItemNum := lbSearch.ItemAtPos(Point(X, Y), True); if (ItemNum < > HintRow) then
begin
HintRow := ItemNum; Application.CancelHint; if HintRow > -1 then
begin
HintString := lbSearch.Items[ItemNum];
if (lbSearch.Canvas.TextWidth(HintString) <= lbSearch.ClientWidth - 25) then
HintString := '';
end else HintString := ''; end;
end;
procedure TfmDWMain.OnShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
if not (HintInfo.HintControl is TListBox) then Exit;
with HintInfo.HintControl as TListBox do
begin
HintInfo.HintPos := lbSearch.ClientToScreen(Point(21, lbSearch.ItemRect(HintRow).Top + 1));
HintStr := HintString; end;
end;
W przykładzie pierwszy znak poszukiwanego tekstu i znaki następne zostają umieszczane na początku
komórki, której wartość pokrywa się z wypisywanym tekstem. W końcu wszystkie frazy są zaznaczone,
które zawierają wpisany tekst.
unit LbxSrch;
interface
uses Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;
type TFrmLbxSrch = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
ListBox1: TListBox;
Label1: TLabel;
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure ListBox1Enter(Sender: TObject);
private { Private declarations }
FPrefix: array[0..255] of char;
public { Public declarations }
end;
var FrmLbxSrch: TFrmLbxSrch;
implementation
{$R *.DFM}
procedure TFrmLbxSrch.FormKeyPress(Sender: TObject; var Key: Char);
{ pamiętaj aby KeyPreview ustawić na True }
var curKey: array[0..1] of char; ndx: integer;
begin
if ActiveControl = ListBox1 then
begin
if key = #8 {Backspace (to klawisz powrotu)} then
begin
if FPrefix[0] < > #0 then
begin
FPrefix[StrLen(FPrefix) - 1] := #0; end end
else begin
curKey[0] := Key; curKey[1] := #0; StrCat(FPrefix, curKey);
ndx := SendMessage(ListBox1.Handle, LB_FINDSTRING, -1, longint(@FPrefix));
if ndx < > LB_ERR then ListBox1.ItemIndex := ndx;
end;
Label1.Caption := StrPas(FPrefix); Key := #0; end;
end;
procedure TFrmLbxSrch.ListBox1Enter(Sender: TObject);
begin
FPrefix[0] := #0; Label1.Caption := StrPas(FPrefix);
end;
end.
procedure TForm1.FormCreate(Sender: TObject);
begin
// wpisz tak lub ustaw to w object inspectorze
ListBox1.Style := lbOwnerDrawFixed;
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var l: Integer; t: String;
begin
with ListBox1 do
begin
Canvas.FillRect(Rect); t := Items[Index]; l := Rect.Right - Canvas.TextWidth(t) - 1;
Canvas.TextOut(l, Rect.Top, t); end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Add(Edit1.Text);
end;
uses ZLib;
{ kompresja streamu}
procedure CompressStream(inpStream, outStream: TStream);
var InpBuf, OutBuf: Pointer; InpBytes, OutBytes: Integer;
begin
InpBuf := nil; OutBuf := nil;
try
GetMem(InpBuf, inpStream.Size); inpStream.Position := 0;
InpBytes := inpStream.Read(InpBuf^, inpStream.Size);
CompressBuf(InpBuf, InpBytes, OutBuf, OutBytes);
outStream.Write(OutBuf^, OutBytes);
finally
if InpBuf < > nil then FreeMem(InpBuf); if OutBuf < > nil then FreeMem(OutBuf);
end; end;
{ Dekompresja streamu }
procedure DecompressStream(inpStream, outStream: TStream);
var InpBuf, OutBuf: Pointer; OutBytes, sz: Integer;
begin
InpBuf := nil; OutBuf := nil;
sz := inpStream.Size - inpStream.Position; if sz > 0 then
try
GetMem(InpBuf, sz); inpStream.Read(InpBuf^, sz);
DecompressBuf(InpBuf, sz, 0, OutBuf, OutBytes);
outStream.Write(OutBuf^, OutBytes);
finally
if InpBuf < > nil then FreeMem(InpBuf); if OutBuf < > nil then FreeMem(OutBuf);
end; outStream.Position := 0;
end;
{ przykład kompresji tekstu RichEdit1 i zapis do pliku ms2.dat }
procedure TForm1.Button1Click(Sender: TObject);
var ms1, ms2: TMemoryStream;
begin
ms1 := TMemoryStream.Create; try ms2 := TMemoryStream.Create;
try
RichEdit1.Lines.SaveToStream(ms1); CompressStream(ms1, ms2);
ShowMessage(Format('Stream Compression Rate: %d %%',
[round(100 / ms1.Size * ms2.Size)]));
ms2.SaveToFile('C:ms2.dat');
finally ms1.Free; end; finally ms2.Free; end;
end;
{ i odczyt streamu z pliku ms2.dat do RichEdit1. }
procedure TForm1.Button2Click(Sender: TObject);
var ms1, ms2: TMemoryStream;
begin
ms1 := TMemoryStream.Create; try ms2 := TMemoryStream.Create;
try
ms1.LoadFromFile('C:ms2.dat'); DecompressStream(ms1, ms2);
RichEdit1.Lines.LoadFromStream(ms2);
finally ms1.Free; end; finally ms2.Free; end;
end;
unit MsFormR;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Memo1: TMemo;
ListBox1: TListBox;
Panel1: TPanel;
Button1: TButton;
Button2: TButton;
Splitter1: TSplitter;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
MemStr1: TMemoryStream;
public
procedure ShowMemStr;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
MemStr1 := TMemoryStream.Create;
end;
procedure TForm1.Button1Click(Sender: TObject);
var Str1: TFileStream;
begin
OpenDialog1.Filter := 'Dowolny plik (*.*)|*.*'; OpenDialog1.DefaultExt := '*';
if OpenDialog1.Execute then
begin
Str1 := TFileStream.Create ( OpenDialog1.Filename, fmOpenRead);
try MemStr1.LoadFromStream (Str1); ShowMemStr;
Button2.Enabled := true;
finally Str1.Free; end; end;
end;
procedure TForm1.ShowMemStr;
begin
Memo1.Lines.LoadFromStream (MemStr1);
end;
procedure TForm1.Button2Click(Sender: TObject);
const ndx: LongInt = 1;
var pch: PChar; tmpC: Char;
begin
pch := MemStr1.Memory; tmpC := pch[ndx]; pch[ndx] := #0;
ListBox1.Items.SetText(MemStr1.Memory); pch[ndx] := tmpC;
if ndx < MemStr1.Size then Inc(ndx)
else
Button2.Enabled := False;
end;
end.
uses Math;
function DoStringMatch(s1, s2: string): Double;
var i, iMin, iMax, iSameCount: Integer;
begin
iMax := Max(Length(s1), Length(s2)); iMin := Min(Length(s1), Length(s2));
iSameCount := -1; for i := 0 to iMax do
begin
if i > iMin then break;
if s1[i] = s2[i] then Inc(iSameCount)
else break;
end;
if iSameCount > 0 then Result := (iSameCount / iMax) * 100
else Result := 0.00;
end;
procedure TForm1.Button1Click(Sender: TObject);
var match: Double;
begin
match := DoStringMatch('SwissDelphiCenter', 'SwissDelphiCenter.ch');
ShowMessage(FloatToStr(match) + ' % match.'); // Rezultat: 85%
end;
const cuthalf = 100; //stała maksymalna długość przetwarzania
var buf: array[0..((cuthalf * 2) - 1)] of integer; // bufor zamiany tablicy w opis
function min3(a, b, c: integer): integer; // funkcja pomocnicza
begin
Result := a; if b < Result then Result := b;
if c < Result then Result := c;
end;
function LeveDist(s, t: string): integer; // funkcja Levenshteina
var i, j, m, n: integer; cost: integer; flip: boolean;
begin
s := copy(s, 1, cuthalf - 1); t := copy(t, 1, cuthalf - 1);
m := length(s); n := length(t); if m = 0 then Result := n
else
if n = 0 then Result := m
else begin
flip := false; for i := 0 to n do buf[i] := i; for i := 1 to m do
begin
if flip then buf[0] := i
else
buf[cuthalf] := i; for j := 1 to n do
begin
if s[i] = t[j] then cost := 0
else cost := 1;
if flip then buf[j] := min3((buf[cuthalf + j] + 1), (buf[j - 1] + 1), (buf[cuthalf + j - 1] + cost))
else
buf[cuthalf + j] := min3((buf[j] + 1), (buf[cuthalf + j - 1] + 1), (buf[j - 1] + cost));
end;
flip := not flip; end; if flip then Result := buf[cuthalf + n]
else
Result := buf[n]; end;
end;
//przykład wykorzystania - na formie pola Edit1 i Edit2 oraz Label1
...
Label1.Caption := IntToStr(LeveDist(Edit1.Text, Edit2.Text));
...
{Str: String; Smb: symbol rozgraniczenia; WordNmbr: Numer wyrazu}
function GetWord(Str, Smb: string; WordNmbr: Byte): string;
var SWord: string; StrLen, N: Byte;
begin
StrLen := SizeOf(Str); N := 1;
while ((WordNmbr >= N) and (StrLen < > 0)) do
begin
StrLen := Pos(Smb, str); if StrLen < > 0 then
begin
SWord := Copy(Str, 1, StrLen - 1); Delete(Str, 1, StrLen); Inc(N);
end else SWord := Str; end;
if WordNmbr <= N then Result := SWord
else Result := '';
end;
Przykład wykorzystania:
GetWord('Oto moje słowo', '', 3); // zwraca -> słowo
// Pozycja łańcucha licząc od końca
function LastPos(SearchStr, Str: string): Integer;
var i: Integer; TempStr: string;
begin
Result := Pos(SearchStr, Str); if Result = 0 then Exit;
if (Length(Str) > 0) and (Length(SearchStr) > 0) then
begin
for i := Length(Str) + Length(SearchStr) - 1 downto Result do
begin
TempStr := Copy(Str, i, Length(Str)); if Pos(SearchStr, TempStr) > 0 then
begin
Result := i; break; end; end; end;
end;
// Szukanie następnego ciągu znaków z określonej pozycji.
function NextPos(SearchStr, Str: string; Position: Integer): Integer;
begin
Delete(Str, 1, Position - 1); Result := Pos(SearchStr, upperCase(Str));
if Result = 0 then Exit;
if (Length(Str) > 0) and (Length(SearchStr) > 0) then
Result := Result + Position + 1;
end;
// pobiera liczbę znaków z pewnej pozycji jako ciąg do szukania.
function NextPosRel(SearchStr, Str: string; Position: Integer): Integer;
begin
Delete(Str, 1, Position - 1); Result := Pos(SearchStr, UpperCase(Str)) - 1;
end;
// prosta zamiana w stringach - wersja.
function ReplaceStr(Str, SearchStr, ReplaceStr: string): string;
begin
while Pos(SearchStr, Str) < > 0 do
begin
Insert(ReplaceStr, Str, Pos(SearchStr, Str));
Delete(Str, Pos(SearchStr, Str), Length(SearchStr));
end; Result := Str;
end;
//zamiana podłańcucha w stringu - wariant
function ReplaceStr(const S, Srch, Replace: string): string;
var I: Integer; Source: string;
begin
Source := S; Result := '';
repeat
I := Pos(Srch, Source); if I > 0 then
begin
Result := Result + Copy(Source, 1, I - 1) + Replace;
Source := Copy(Source, I + Length(Srch), MaxInt);
end else Result := Result + Source;
until I< = 0;
end;
procedure TMainForm.LoadFileIntoList(TextFileName: string;
AWebPage: TStringList; WithFilter: Boolean);
var CurrentFile: TStringList;
begin
CurrentFile := TStringList.Create; CurrentFile.LoadFromFile(TextFileName);
if WithFilter then FilterHTML(CurrentFile,AWebPage)
else
with AWebPage do AddStrings(CurrentFile); CurrentFile.Free;
end;
procedure TMainForm.FilterHTML(FilterInput, AWebPage: TStringList);
var i, j: LongInt; S: string;
begin
Memo1.Lines.Clear; Memo1.Lines := FilterInput;
with AWebPage do
begin
Memo1.SelectAll; j := Memo1.SelLength;
if j > 0 then
begin
i := 0; repeat // szuka ENTERa
if Memo1.Lines.GetText[i] = Char(VK_RETURN) then
S := S + #10#13;
else if Memo1.Lines.GetText[i] = ' <' then repeat inc(i);
until Memo1.Lines.GetText[i] = ' >'
else // szuka TABulatora
if Memo1.Lines.GetText[i] = Char(VK_TAB) then S := S + ' '
else S := S + Memo1.Lines.GetText[i]; // dokłada tekst
inc(i); until i = j + 1;
Add(S); // dodaje wiersz w WebPage
end else
Add('Brak danych w tekście pliku.'); end;
end;
Aktywacja funkcji:
LoadFileIntoList("filename.txt",Webpage, True);
//gdzie:
filename - nazwa pliku, który ma być oczyszczony...
WebPage - to TStringList
True - gdy ostatni parametr funkcji jest True to filtr kasuje elementy HTML; False - zostawia.
function Seps(As_Arg: Char): Boolean;
begin
Seps := As_Arg in [#0..#$1F, '', '.', ',', '?', ':', ';', '(', ')', '/', ''];
end;
function WordCount(CText: string): Longint;
var Ix: Word; Work_Count: Longint;
begin
Work_Count := 0; Ix := 1; while Ix <= Length(CText) do
begin
while (Ix <= Length(CText)) and (Seps(CText[Ix])) do Inc(Ix);
if Ix <= Length(CText) then
begin
Inc(Work_Count); while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do
Inc(Ix); end;
end;
Word_Count := Work_Count;
end;
{ Aby policzyć słowa w komponencie TMemo wywołaj: WordCount(Memo1.Text) ;}
function DeleteLineBreaks(const S: string): string;
var Source, SourceEnd: PChar;
begin
Source := Pointer(S); SourceEnd := Source + Length(S);
while Source < SourceEnd do
begin
case Source^ of //znaki konca linii i zmiany wiersza zastępujemy spacjami
#10: Source^ := #32;
#13: Source^ := #32;
end; Inc(Source); end; Result := S;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
end;
procedure TForm1.Button2Click(Sender: TObject);
var find: string; text: string; st, len: integer; res: integer;
begin
if Memo1.SelStart >= Length(Memo1.Text) then
Memo1.SelStart := 0; st := Memo1.SelStart + 1;
if (Memo1.SelLength <= 0) or (not CheckBox1.Checked) then
begin
inc(st, Memo1.SelLength); len := Length(Memo1.Text) - st;
end else
len := Memo1.SelLength; text := copy(Memo1.Text, st, len);
find := Edit1.Text; res := pos(find, text); if res = 0 then
begin
ShowMessage('Szukanego ciągu :' + find + 'nie znaleziono'); Exit;
end;
Memo1.SelStart := res + st - 2; Memo1.SelLength := length(find);
end;
// zamiana strumienia binarnego w ciąg HEX
function StreamToHex(Buf: TStream): string;
const Convert: array[0..15] of Char = '0123456789ABCDEF';
var i, p: integer; B: byte;
begin
SetLength(Result, Buf.Size * 2); p := Buf.Position; Buf.Position := 0;
for i := 1 to Buf.Size do
begin
Buf.Read(B, 1); Result[(i * 2) - 1] := Convert[B shr $4];
Result[(i * 2)] := Convert[B and $F]; end;
Buf.Position := p;
end;
//i zamiana HEX w ciąg binarny
procedure HexToStream(Hex: string; Buf: TStream);
const Convert: array['0'..'f'] of SmallInt =
(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, -1, -1, -1, -1, -1, -1,
-1, 10, 11, 12, 13, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, 10, 11, 12, 13, 14, 15);
var i, p: integer; B: Byte;
begin
if Buf.Size < Length(Hex) div 2 then Buf.Size := Length(Hex) div 2;
p := Buf.Position; Buf.Position := 0; i := 1;
while i <= Length(Hex) do
begin
if not (Hex[i] in ['0'..'f']) or not (Hex[i + 1] in ['0'..'f']) then Break;
B := Byte((Convert[Hex[i]] shl 4) + Convert[Hex[i + 1]]); Buf.Write(B, 1);
Inc(i, 2);
end; Buf.Position := p;
end;
//przykład wykorzystania:
var St: TStream;
begin
St := TMemoryStream.Create; Memo1.Lines.SaveToStream(St);
Memo1.Text := StreamToHex(St); St.Destroy;
end;
function WinToDos(St: string): string;
var Ch: PChar;
begin
Ch := StrAlloc(Length(St) + 1); AnsiToOem(PChar(St), Ch);
Result := Ch; StrDispose(Ch)
end;
function DosToWin(St: string): string;
var Ch: PChar;
begin
Ch := StrAlloc(Length(St) + 1); OemToAnsi(PChar(St), Ch);
Result := Ch; StrDispose(Ch)
end;
function StringToPWide(sStr: string; var iNewSize: integer): PWideChar;
var pw: PWideChar; iSize: integer;
begin
iSize := Length(sStr) + 1; iNewSize := iSize * 2;
pw := AllocMem(iNewSize);
MultiByteToWideChar(CP_ACP, 0, PChar(sStr), iSize, pw, iNewSize);
Result := pw;
end;
function PWideToString(pw: PWideChar): string;
var p: PChar; iLen: integer;
begin
iLen := lstrlenw(pw) + 1; GetMem(p, iLen);
WideCharToMultiByte(CP_ACP, 0, pw, iLen, p, iLen * 2, nil, nil);
Result := p; FreeMem(p, iLen);
end;
//przykład wykorzystania:
procedure TForm1.Button1Click(Sender: TObject);
var iSize: integer;
begin
ChangeWallpaper(StringToPWide('C:1.jpg', iSize));
end;
function WideStringToString(const ws: WideString; codePage: Word): AnsiString;
var l: integer;
begin
if ws = '' then Result := ''
else begin
l := WideCharToMultiByte(codePage,
WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
@ws[1], -1, nil, 0, nil, nil);
SetLength(Result, l - 1); if l > 1 then
WideCharToMultiByte(codePage,
WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
@ws[1], -1, @Result[1], l - 1, nil, nil);
end;
end; { WideStringToString }
function StringToWideString(const s: AnsiString; codePage: Word): WideString;
var l: integer;
begin
if s = '' then Result := ''
else begin
l := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@s[1]), -1, nil, 0);
SetLength(Result, l - 1); if l > 1 then
MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@s[1]),
-1, PWideChar(@Result[1]), l - 1);
end;
end; { StringToWideString }