Składnia Object Pascala

1.   Niszczenie katalogu ze wszystkimi podkatalogami i plikami

Funkcja zwraca FALSE jeżeli operacja się nie powiedzie a usuwa wszystkie pliki w katalogu i na końcu sam katalog..
function DeleteDirectory(aDirectoryName : string; aContent : boolean = true) : boolean;
var DirInfo: TSearchRec; r : Integer;
begin
result := true;   if aContent then begin
r := FindFirst(aDirectoryName + '\*.*', FaAnyfile, DirInfo);
while (r = 0) and result do begin
if (DirInfo.Attr and FaVolumeId < > FaVolumeID) then begin
if (DirInfo.Attr and FaDirectory = FaDirectory) and (DirInfo.Name < > '.') and (DirInfo.Name < > '..') then
result := DeleteDirectory(aDirectoryName + DirInfo.Name)
else if (DirInfo.Attr and FaDirectory < > FaDirectory) then
result := sysUtils.DeleteFile(aDirectoryName + '\' + DirInfo.Name);
end;   r := FindNext(DirInfo);   end;   SysUtils.FindClose(DirInfo);
end;   if Result then
result := RemoveDir(aDirectoryName);
end;

2.   Szukanie słowa w stringu

Przykład szukane słowa wprowadza do zmiennej ...
var FoundStr : string;
begin
FoundStr := FindStr('This is an example',3,' ');
if FindStr('red,yellow,blue',2,',') = 'blue' then .... else ....;
end;

function FindStr(S : string; I : integer; Sign : string) : string;
var teller,t,t1,t2 : shortint;
begin
S := Sign + S + Sign;   teller := 1;   t := 0;
while t < I do begin
if Copy(S,teller,1) = Sign then   Inc(t);   inc(teller);   end; {while teller}
t1 := teller;
if Copy(S,teller,1) = Sign then result := '' else begin     Inc(teller);
while Copy(S,teller,1) < > Sign do   Inc(teller);   t2 := teller - t1;
result := copy(S,t1,t2);   end; {if}
end;

3.   Zamiana stringów zakończonych zerem

funkcja nieudokumentowana ale skuteczna...
var SearchStr, Patt, NewStr: string; Offset: Integer;
begin
Result := '';   SearchStr := OriginalString;   Patt := Pattern;   NewStr := OriginalString;
while SearchStr < > '' do begin
Offset := Pos(Patt, SearchStr);   // Was AnsiPos
if Offset = 0 then begin
Result := Result + NewStr;   Break;
end;
Result := Result + Copy(NewStr, 1, Offset - 1) + Replace;
NewStr := Copy(NewStr, Offset + Length(Pattern), MaxInt);
SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
end;

end;

4.   Sortowanie TStringlist - wybrane metody

I. Sortowanie według daty - aby w TListBox daty były uporządkowane ,jak niżej:
12.03.2003
13.03.2003
29.01.2003
30.03.2003
Należy utworzyć TStringList , uporządkować je wg. CustomSort i wprowadzić ponownie do TListBoxa.

function CompareDates(List: TStringList; Index1, Index2: Integer): Integer;
var d1, d2: TDateTime;
begin
d1 := StrToDate(List[Index1]);   d2 := StrToDate(List[Index2]);
if d1 < d2 then   Result := -1
else   if d1 > d2 then   Result := 1
else   Result := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var sl: TStringList;
begin
sl := TStringList.Create;
try   // uprzednio ustawiony TListBox : listbox1.Sorted := False !
sl.Assign(listbox1.Items);   sl.CustomSort(CompareDates);   listbox1.Items.Assign(sl);
finally   sl.Free   end; end;

end.

// II. Sortowanie według wartości liczbowej:
function CompareInt(List: TStringList; Index1, Index2: Integer): Integer;
var d1, d2: Integer; r1, r2: Boolean;

function IsInt(AString : string; var AInteger : Integer): Boolean;
var Code: Integer;
begin
Val(AString, AInteger, Code);   Result := (Code = 0);
end;

begin
r1 := IsInt(List[Index1], d1);   r2 := IsInt(List[Index2], d2);   Result := ord(r1 or r2);
if Result < > 0 then begin
if d1 < d2 then   Result := -1   else if d1 > d2 then   Result := 1
else   Result := 0;   end else
Result := lstrcmp(PChar(List[Index1]), PChar(List[Index2]));
end;

procedure TForm1.Button1Click(Sender: TObject);
var sl: TStringList;
begin
sl := TStringList.Create;   try   //to samo w TListBox: listbox1.Sorted := False;
sl.Assign(listbox1.Items);   sl.CustomSort(CompareInt);   listbox1.Items.Assign(sl);
finally   sl.Free;   end;
end;

5.   Niszczenie pozycji w tablicy dynamicznej - dynamic array

type   TArrayString = array of string;

procedure DeleteArrayIndex(var X: TArrayString; Index: Integer);
begin
if Index > High(X) then Exit;
if Index < Low(X) then Exit;
if Index = High(X) then begin
SetLength(X, Length(X) - 1);   Exit;   end;
Finalize(X[Index]);
System.Move(X[Index +1], X[Index], (Length(X) - Index -1) * SizeOf(string) + 1);
SetLength(X, Length(X) - 1);
end;

// Przykład : niszczenie 2 pozycji w tablicy....
procedure TForm1.Button2Click(Sender: TObject);
var a: TArrayString;
begin
DeleteArrayIndex(a, 2);
end;

6.   Automatyczny zapis /odczyt ustawień

Zapis komponentów pochodnych od TWinControl, np, zapis wszystkich stron z TPageControl do streamu, a ten do pliku.

private
procedure SaveConfig(fn: string);
procedure LoadConfig(fn: string);
end;

implementation

{....}

procedure TForm1.SaveConfig(fn: string);   // fn: Filename where to save the stream
var Stream: TFileStream; i, j: Integer; ObjName: string[255];
begin
Stream := TFileStream.Create(fn, fmCreate);
try Stream.Position := 0;   // Walk throug every Control on every Page of a PageControl
for j := 0 to PageControl.PageCount - 1 do begin
for i := 0 to PageControl.Pages[j].ControlCount - 1 do begin
if PageControl.Pages[j].Controls[i] is TWinControl then begin
// If the control is a descendant of TWinControl, then save it in the stream incl. name and length
ObjName := PageControl.Pages[j].Controls[i].Name;
Stream.WriteBuffer(ObjName, Length(ObjName) + 1);
Stream.WriteComponent(PageControl.Pages[j].Controls[i]);
end; end; end; finally   Stream.Free;   end;
end;

procedure TForm1.LoadConfig(fn: string); // fn: Filename from where to load the stream
// Loads the controls back from the stream
var Stream: TFileStream; ObjName: string[255]; ObjNameLen: Byte; i, j: Integer;
begin
Stream := TFileStream.Create(fn, fmOpenRead or fmShareDenyNone);
try   Stream.Position := 0;   // walk through the stream
while Stream.Position do begin
try   // get objectname
Stream.Read(ObjName[0], 1);   ObjNameLen := Byte(ObjName[0]);
Stream.Read(ObjName[1], ObjNameLen);
finally   end;   // Search the control on the PageControl
for j := 0 to PageControl.PageCount - 1 do begin
for i := 0 to PageControl.Pages[j].ControlCount - 1 do begin
if PageControl.Pages[j].Controls[i] is TWinControl then begin
if ObjName = PageControl.Pages[j].Controls[i].Name then begin
try
if PageControl.Pages[j].Controls[i] is TCheckbox then   // TCheckbox has to be set to False
PageControl.Pages[j].Controls[i] as TCheckbox).Checked := False;
// load control
Stream.ReadComponent(PageControl.Pages[j].Controls[i]);
finally   end; end; end; end; end; end;
finally   Stream.Free;   end;
end;

{ Zapis ustawien}
procedure TForm1.Button2Click(Sender: TObject);
begin
SaveConfig('pagecontrol.dat');
end;

{ Odczyt ustawien}
procedure TForm1.Button1Click(Sender: TObject);
begin
LoadConfig('pagecontrol.dat');
end;

7.   Jak wczytać z pliku tekstowego tekst z dwóch kolumn do 2-óch komponentów ComboBox?

Załóżmy, że masz plik tekstowy z dwiema kolumnami: w jednej wpisane są kraje, a po prawej stolice tych krajów. Teraz chcesz każdą kolumnę wczytać do osobnego komponentu "ComboBox":

var F: TextFile; Kraj: String[20]; // na każdą kolumnę przeznaczono 20 znaków
Stolica: String[20];
begin

AssignFile(F, 'PLIK.TXT');  Reset(F);  // otwarcie pliku
try while not Eof(F) do begin
Readln(F, Kraj, Stolica);   // wczytanie 2-óch kolumn
ComboBox1.Items.Add(Kraj);   // dodanie ich do komponentu
ComboBox2.Items.Add(Stolica);
end;   finally   CloseFile(F);
end;

8.   Jak zamknąć inną aplikację znając jej ścieżkę?

Jeżeli znasz ścieżkę uruchomionego programu to możesz zamknąć ją. Jak? Pokazuje to poniższy kod. Aha, do listy modułów uses musisz dodać słowo "TLHelp32".

var PHandle, FHandle: THandle; Process:TProcessEntry32; Done, Next: Boolean; EXE : String; // ścieżka programu
begin
EXE := 'C:\Windows\Pulpit\prog.exe';
FHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
Process.dwSize := Sizeof(Process);   Next := Process32First(FHandle,Process);
while Next do begin   { jesli sciezka dostepu sie zgadza }
if AnsiLowerCase(Process.szExeFile) = AnsiLowerCase(EXE) then begin
PHandle:=OpenProcess(PROCESS_TERMINATE, False, Process.th32ProcessID);
Done := TerminateProcess(PHandle,0);   { to probujemy zabic aplikacje }
if not Done then   MessageBox(Handle, 'Błąd', 'Błąd', MB_OK);   end;
Next := Process32Next(FHandle,Process);   end;
CloseHandle(FHandle);
end;

9. Jak narysować tekst w pionie?

Posłuż się takim kodem:
procedure TForm1.Button1Click(Sender: TObject);
var LF : TLogFont;
begin
Canvas.Font.Size := 24;   GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @lf);
lf.lfEscapement := 90 * 10;   lf.lfOutPrecision := OUT_TT_ONLY_PRECIS;
Canvas.Font.Handle := CreateFontIndirect(LF);
SetGraphicsMode(Canvas.Handle, GM_ADVANCED);
Canvas.Brush.Style := bsClear;
Canvas.TextOut( 20, 200, 'Hello World!');
end;

10.   Jak zrobić aby formularz był przeźroczysty?

W sekcji private:
procedure CreateParams(var Params: TCreateParams); override;
//Teraz w sekcji Implementation:
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

//inna wersja programu o przezroczystej formie
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.BorderStyle:=bsNone; Form1.Brush.Style:=bsClear; Form1.Refresh;
end;

11.   Utworzenie listy wszystkich plików znajdujących się w folderze C:\sciezka\folder i w jego podfolderach

procedure TForm1.DodajPlikiFolderu(s: String);
var sr: TSearchRec;   czyKoniec: Integer;
begin
czyKoniec:=0;   if (s[Length(s)] < > '/') and (s[Length(s)] < > '\')
then s:=s+'\';   FindFirst(s+'*.*',FaAnyFile,sr);
while czyKoniec=0 do begin
if (sr.Name < > '.') and (sr.Name < > '..')
then   if DirectoryExists(s+sr.Name)   then DodajMP3(s+sr.Name+'\')
else ListBox1.Items.Add(s+sr.Name);
czyKoniec:=FindNext(sr);   end;
sysutils.FindClose(sr);
end;

12.   Wpisanie ciągu znaków s typu String ze schowka w miejsce ustawienia kursora tekstowego

uses ClipBrd;

procedure TForm1.Wpisz(s: String);
begin
ClipBoard.AsText:=s;
keybd_event(Ord(Chr(17)),0,0,0);   keybd_event(Ord(Chr(86)),0,0,0);
keybd_event(Ord(Chr(86)),0,KEYEVENTF_KEYUP,0);
keybd_event(Ord(Chr(17)),0,KEYEVENTF_KEYUP,0);
end;

13.   Reakcja po wciśnięciu określonego klawisza na klawiaturze

var MainHook: hHook;

function KeyHook(code: Integer; wPar : wParam; lPar : lParam): Longint; StdCall;
var kState: TKeyboardState;
begin
GetKeyboardState(kState);   if (kState[32] and $80) < > 0
then ShowMessage('Wcisnąłeś spację');
if (kState[65] and kState[66] and not kState[67] and $80) < > 0
then ShowMessage('Wcisnąłeś jednocześnie klawisze A i B przy czym klawisz C nie był wciśnięty');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MainHook:=SetWindowsHookEx(WH_Keyboard,KeyHook,hInstance,0);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
UnhookWindowsHookEx(MainHook);
end;

uwaga: numer klawisza (w przykładzie 32 oznacza spację) sprawdzić można wywołując procedurę OnKeyDown dla Memo:
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
ShowMessage(IntToStr(Key));
end;

14.   Przechwycenie adresu URL aktywnego okna przeglądarki

function TForm1.GetUrl: String;
var ie,toolbar,combo,comboBoxEx,edit,worker: HWND;
begin
ie:=FindWindow(PChar('IEFrame'),nil);
worker:=FindWindowEx(ie,0,'WorkerA',nil);
toolbar:=FindWindowEx(worker,0,'ReBarWindow32',nil);
comboBoxEx:=FindWindowEx(toolbar,0,'ComboBoxEx32',nil);
combo:=FindWindowEx(comboBoxEx,0,'ComboBox',nil);
edit:=FindWindowEx(combo,0,'Edit',nil);   Result:=GetText(edit);
end;

function TForm1.GetText(windowHandle: HWND): String;
var txtLength: Integer; buffer: String;
begin
txtLength:=SendMessage(windowHandle,WM_GETTEXTLENGTH,0,0);
txtLength:=txtLength+1;   SetLength(buffer,txtLength);
SendMessage(windowHandle,WM_GETTEXT,txtLength,longint(@buffer[1]));
Result:=buffer;
end;

GetUrl;
uwaga: w przypadku braku otwartego okna przeglądarki internetowej funkcja zwróci pusty ciąg znaków

15.   Ukrycie belki na pasku zadań

procedure TForm1.FormCreate(Sender: TObject);
var es: Integer;
begin
es:=GetWindowLong(Application.Handle,GWL_EXSTYLE);
es:=es or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW;
SetWindowLong(Application.Handle,GWL_EXSTYLE,es);
end;

16.   Ukrycie paska tytułowego formy

procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle,GWL_STYLE,GetWindowLong(Form1.Handle,GWL_STYLE)
and not WS_CAPTION);
Height:=ClientHeight;
end;

17.   Zapis fontów do rejestru /do streamu

type FontRec = packed record
Color: TColor;
LogFont: TLogFont;
end;

// zapis do rejestru...
procedure SaveFontToReg(reg: TRegistry; const key, id: string; Font: TFont);
var fRec: FontRec;
begin
if Windows.GetObject(Font.Handle, SizeOf(fRec.LogFont), @fRec.LogFont) > 0 then begin
if reg.OpenKey(key, True) then   try
fRec.Color := Font.Color;   reg.WriteBinaryData(id, fRec, SizeOf(fRec));
finally   reg.CloseKey;   end; end;
end;

// odczyt z rejestru...
procedure LoadFont(reg: TRegistry; const key, id: string; Font: TFont);
var fRec: FontRec;
begin
if reg.OpenKey(key, False) then   try
if reg.ReadBinaryData(id, frec, SizeOf(fRec)) = SizeOf(fRec) then
Font.Handle := CreateFontIndirect(fRec.LogFont);   Font.Color := fRec.Color;
finally   reg.CloseKey; end;
end;

// zapis do streamu...
procedure WriteFontToStream(s: TStream; Font: TFont);
var fRec: FontRec; sz: integer;
begin
sz := SizeOf(fRec.LogFont);
if Windows.GetObject(Font.Handle, sz, @fRec.LogFont) > 0 then begin
s.Write(sz, SizeOf(Integer));   fRec.Color := Font.Color;   s.Write(fRec, SizeOf(fRec));
end else begin   sz := 0;   s.Write(sz, SizeOf(Integer));
end; end;

// odczyt ze streamu...
procedure ReadFont(s: TStream; Font: TFont);
var fRec: FontRec; sz: integer;
begin
s.read(sz, SizeOf(Integer));   if sz = SizeOf(fRec.LogFont) then begin
s.read(fRec, SizeOf(fRec));   Font.Handle := CreateFontIndirect(fRec.LogFont);
Font.Color := fRec.Color;
end;   end;

18.   Konwersja stringa na HKEY / HKey na String

const
HKEYNames: array[0..6] of string =
('HKEY_CLASSES_ROOT', 'HKEY_CURRENT_USER', 'HKEY_LOCAL_MACHINE', 'HKEY_USERS',
'HKEY_PERFORMANCE_DATA', 'HKEY_CURRENT_CONFIG', 'HKEY_DYN_DATA');

function HKEYToStr(const Key: HKEY): string;
begin
if (key < HKEY_CLASSES_ROOT) or (key > HKEY_CLASSES_ROOT+6) then   Result := ''
else   Result := HKEYNames[key - HKEY_CLASSES_ROOT];
end;

function StrToHKEY(const KEY: string): HKEY;
var i: Byte;
begin
Result := $0;   for i := Low(HKEYNames) to High(HKEYNames) do begin
if SameText(HKEYNames[i], KEY) then   Result := HKEY_CLASSES_ROOT + i;
end; end;

19.   Zapamiętanie stylu fontów (fontStyle) w pliku INI (from: ralf steinhaeusser)

procedure strtofont(str: string; font: tfont);
function fonttostr(font: tfont): string;

procedure strtobrush(str : string; brush : tbrush);
function brushtostr(brush: tbrush): string;

implementation

uses sysutils;

function firstwordseperator(sep : string;var workstr : string; cut : boolean) : string;
var counter : word;
begin // "abcxdef" -> counter=4
counter:=pos(sep,workstr); if counter >0 then
result:=copy(workstr,1,counter-1) else result:=workstr;
if cut then
begin
if counter >0 then delete(workstr,1,counter+length(sep)-1)
else workstr:=''; end;
end;

function tok(sep: string; var s: string): string;
// gives back part of string before the given seperator
// and throws away this part and the seperator
begin
result:=firstwordseperator(sep,s,true);
end;

procedure yesno(yes : boolean;var str:string);
begin
if yes then str:=str+'y'
else
str:=str+'n';
end;

function fonttostr(font: tfont): string;
begin
{koduje wszystkie atrybuty TFont na ciąg znaków}
result := '';
result := result + inttostr(font.color) + ' '; result := result + inttostr(font.height) + ' ';
result := result + font.name + ' '; result := result + inttostr(ord(font.pitch)) + ' ';
result := result + inttostr(font.pixelsperinch) + ' '; result := result + inttostr(font.size) + ' ';
yesno(fsbold in font.style,result); yesno(fsitalic in font.style,result);
yesno(fsunderline in font.style,result); yesno(fsstrikeout in font.style,result);
end;

procedure strtofont(str: string; font: tfont);
begin
if str = '' then exit;
font.color := strtoint(tok(' ', str)); font.height := strtoint(tok(' ', str));
font.name := tok(' ', str); font.pitch := tfontpitch(strtoint(tok(' ', str)));
font.pixelsperinch := strtoint(tok(' ', str)); font.size := strtoint(tok(' ', str));
font.style := [];
if str[1] = 'y' then font.style := font.style + [fsbold];
if str[2] = 'y' then font.style := font.style + [fsitalic];
if str[3] = 'y' then font.style := font.style + [fsunderline];
if str[4] = 'y' then font.style := font.style + [fsstrikeout];
end;

function brushtostr(brush: tbrush): string;
begin
result := ''; result := result + inttostr(brush.color) + ' ';
case brush.style of
bssolid : result:=result+'1'; bsclear : result:=result+'2';
bsbdiagonal : result:=result+'3'; bsfdiagonal : result:=result+'4';
bscross : result:=result+'5'; bsdiagcross : result:=result+'6';
bshorizontal : result:=result+'7'; bsvertical : result:=result+'8';
end; end;

procedure strtobrush(str : string; brush : tbrush);
begin
if str = '' then exit; brush.color := strtoint(tok(' ', str));
brush.style := bssolid;
case upcase(str[1]) of // enumerated like in helppage
'1' : brush.style := bssolid; '2' : brush.style := bsclear;
'3' : brush.style := bsbdiagonal; '4' : brush.style := bsfdiagonal;
'5' : brush.style := bscross; '6' : brush.style := bsdiagcross;
'7' : brush.style := bshorizontal; '8' : brush.style := bsvertical;
end; end;

20.  TStringList w TIniFile

uses classes;

type tinistringlist = class( tstringlist )
public
procedure loadfromini(const filename, section: string);
procedure savetoini(const filename, section: string);
end;

implementation

uses inifiles, sysutils;

procedure tinistringlist.loadfromini(const filename, section: string);
var index: integer; line: string;
begin
with tinifile.create( filename ) do
try
readsectionvalues( section, self); for index:= 0 to count - 1 do
begin { Usuń nazwę identyfikatora ..}
line:= values[ inttostr( index ) ]; { Usuń tyldy. }
system.delete( line, 1, 1); strings[ index ]:= line; end;
finally free; end;
end;

procedure tinistringlist.savetoini( const filename, section: string);
var index: integer; line: string;
begin
with tinifile.create( filename ) do
try erasesection( section ); for index:= 0 to count - 1 do
begin
{ Zapisz spacji, pustych linii..}
line:= '~' + strings[ index ]; writestring( section, inttostr( index ), line); end;
finally free; end;
end;

end.

Zastosowanie:
var l: tinistringlist;
begin
l := tinistringlist.create; l.loadfromini('myfile.ini', 'alati'); {pobierz..}
l.free;
end.

21.   Usuwanie wielu elementów TListBox na raz

To tworzy plik tymczasowy, który dokona niezbędnych transferów (Uwaga: właściwość "MultiSelect" TListBox należy zmienić na "true").

To musi być zadeklarowane w sesion private.
procedure TForm1.ApagarVarios(ListBox:TListBox);
var i:integer; lista1, lista2:TStringList;
begin
for i:=0 to ListBox.Items.Count-1 do if ListBox.Selected[i] then
begin
ListBox.Items.Strings[i]:='';
ListBox.Items.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end;
Lista1:=TStringList.Create; Lista2:=TStringList.Create;
lista1.LoadFromFile(extractfilepath(application.ExeName)+'itens.txt');
for i:=0 to lista1.Count-1 do begin
if lista1.Strings[i] < >'' then begin
lista2.Add(lista1.Strings[i]);
lista2.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end else
lista2.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end;
ListBox.Items.LoadFromFile(extractfilepath(application.ExeName)+'itens.txt');
deletefile(extractfilepath(application.ExeName)+'itens.txt');
end;

// Dodaj niektóre elementy w TListBox
procedure TForm1.btnAdicionaClick(Sender: TObject);
var S : String;
begin
S := InputBox('Adicionar ítens', 'Digite algo' , '');
ListBox1.Items.Add(S);
ListBox1.Items.SaveToFile(extractfilepath(application.ExeName)+'itens.txt');
end;

// Teraz wywołanie procedury.
procedure TForm1.btnApagaClick(Sender: TObject);
begin
if not (ListBox1.Items.Count=0) and (ListBox1.Selected[ListBox1.ItemIndex]) then
ApagarVarios(ListBox1);
end;

22.  Konwersja tekstu z OEM na Ansi - od Delphi2 wzwyż.

function ConvertAnsiToOem(const S : string) : string;
{$IFNDEF WIN32}var Source, Dest : array[0..255] of Char; {$ENDIF}
begin
{$IFDEF WIN32}
SetLength(Result, Length(S)); if Length(Result) > 0 then
AnsiToOem(PChar(S), PChar(Result));
{$ELSE}
if Length(Result) > 0 then
begin
AnsiToOem(StrPCopy(Source, S), Dest); Result := StrPas(Dest);
end; {$ENDIF}
end; { ConvertAnsiToOem }

function ConvertOemToAnsi(const S : string) : string;
{$IFNDEF WIN32} var Source, Dest : array[0..255] of Char;{$ENDIF}
begin
{$IFDEF WIN32}
SetLength(Result, Length(S)); if Length(Result) > 0 then
OemToAnsi(PChar(S), PChar(Result));
{$ELSE}
if Length(Result) > 0 then
begin
OemToAnsi(StrPCopy(Source, S), Dest); Result := StrPas(Dest);
end; {$ENDIF}
end; { ConvertOemToAnsi }

23.  Jak uzyskać listę plików ze wszystkich podkatalogów?

procedure ScanDir(StartDir: string; Mask:string; List:TStrings);
var SearchRec : TSearchRec;
begin
if Mask = '' then Mask := '*.*';
if StartDir[Length(StartDir)] < > '\' then StartDir := StartDir + '\';
if FindFirst(StartDir+Mask, faAnyFile, SearchRec) = 0 then
begin repeat
Application.ProcessMessages;
if (SearchRec.Attr and faDirectory) < > faDirectory then
List.Add(StartDir + SearchRec.Name)
else if (SearchRec.Name < > '..') and (SearchRec.Name < > '.') then
begin
List.Add(StartDir + SearchRec.Name + '\');
ScanDir(StartDir + SearchRec.Name + '\',Mask,List);
end;
until FindNext(SearchRec) < > 0; FindClose(SearchRec); end;
end;

Przykład wywołania z połączeniem parametrów:
1. nazwa folderu
2. maska - domyślnie *.*
3. miejsce przechowywania rezultatów - wszelkie pochodne TString, takich jak TStringList

procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Clear; ScanDir('c:','',ListBox1.Items);
Label1.Caption := IntToStr(ListBox1.Items.Count);
end;

24.  Dodanie objektu do listy typu TStrings i następnie jego zniszczenie.

procedure TForm1.FormCreate(Sender: TObject);
var Icon: TIcon;
begin
Icon := TIcon.Create;
Icon.LoadFromFile('C:\Program Files\BorlandImages\CONSTRUC.ICO');
ListBox1.Items.AddObject('Item 0', Icon);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
ListBox1.Items.Objects[0].Free;
end;

25.  Wstaw dowolny program do pliku EXE.

W przykładzie plik ARJ.EXE kompilujemy za pomocą Brcc32.exe do pliku zasobów (test.res) i wstawiamy do programu dla Delphi. Taki plik zawsze możemy wyciągnąć z pliku wykonywalnego programu:

implementation
{$R *.DFM}
{$R test.res} //to nasz plik RES

procedure ExtractRes(ResType, ResName, ResNewName : String);
var Res : TResourceStream;
begin
Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));
Res.SavetoFile(ResNewName); Res.Free;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
//zapisuje arj.exe w bieżącym folderze
ExtractRes('EXEFILE', 'ARJ', 'ARJ.EXE');
end;

26.  Podział i przenoszenie słów w polach TEdit, TMemo lub TRichEdit?

Poniższy przykład tworzy procedurę podziału słów i transferu w polu TMemo poprzez uzycie wywołania - EM_SETWORDBREAKPROC.

var OriginalWordBreakProc : pointer; NewWordBreakProc : pointer;

function MyWordBreakProc(LPTSTR : pchar; ichCurrent : integer; cch : integer;
code : integer) : integer {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
result := 0;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OriginalWordBreakProc := Pointer( SendMessage(Memo1.Handle,
EM_GETWORDBREAKPROC, 0, 0));
{$IFDEF WIN32}
NewWordBreakProc := @MyWordBreakProc;
{$ELSE}
NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance);
{$ENDIF}
SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0,
longint(NewWordBreakProc));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0,
longint(@OriginalWordBreakProc));
{$IFNDEF WIN32}
FreeProcInstance(NewWordBreakProc);
{$ENDIF}
end;

27.  Pobranie znaku ze strumienia pamięci.

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 := 'Any file (*.*)|*.*'; 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.

28.  Użycie funkcji PosEx zamiast Pos.

Funkcja PosEx pojawiła się od Delphi 7 w module StrUtils. Kody tych funkcji::

Function Pos(Substr: String; S: String): Integer;
Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;

Nowa funkcja PosEx pozwala na określenie pozycji wyjściowej w ciągu wyszukiwania, która zwalnia od konieczności zmiany oryginalnego łańcucha.
Poniżej znajduje się funkcja z modułu StrUtils - jezeli masz starszą wersję Delphi to wykorzystaj ją w programie zamiast Pos:

Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;
var I,X: Integer; Len, LenSubStr: Integer;
begin
If Offset = 1 Then Result := Pos(SubStr, S)
Else begin
I := Offset; LenSubStr := Length(SubStr); Len := Length(S) - LenSubStr + 1;
While I <= Len Do
begin
If S[I] = SubStr[1] Then
begin
X := 1; While (X < LenSubStr) And (S[I + X] = SubStr[X + 1]) Do Inc(X);
If (X = LenSubStr) Then
begin
Result := I; Exit; End; End; Inc(I); End; Result := 0; End;
End;

29.  Klonowanie obiektów w Delphi.

Tworzenie kopii objektów w Delphi jest bardzo proste: konwertujemy objekt do tekstu i następnie - z powrotem. W ten sposób duplikat posiada wszystkie właściwości, z wyjątkiem odniesienia do obsługi zdarzeń. Aby przekonwertować element do pliku i odwrotnie, musimy użyć funkcji WriteComponent (TComponent) i ReadComponent (TComponent). Przy tym do strumienia zapisujemy zasoby binarne, posiłkując się przy tym (konwersja do tekstu) funkcją ObjectBinaryToText:

function ComponentToString(Component: TComponent): string;
var ms: TMemoryStream; ss: TStringStream;
begin
ss := TStringStream.Create(' '); ms := TMemoryStream.Create;
try ms.WriteComponent(Component); ms.position := 0;
ObjectBinaryToText(ms, ss); ss.position := 0; Result := ss.DataString;
finally ms.Free; ss.free; end;
end;

procedure StringToComponent(Component: TComponent; Value: string);
var StrStream:TStringStream; ms: TMemoryStream;
begin
StrStream := TStringStream.Create(Value);
try ms := TMemoryStream.Create;
try ObjectTextToBinary(StrStream, ms); ms.position := 0;
ms.ReadComponent(Component);
finally ms.Free; end;
finally StrStream.Free; end;
end;

30.  Podział jednej linii znaków na 3 linie.

W przykładzie łancuch aStr jest dzielony na 3 łańcuchy St1, St2, St3 długści Long1, Long2, Long3 w zależności od długości łancucha:

procedure DivPart(aStr: string; var St1, St2, St3: string; Long1, Long2, Long3:byte);
var i, pos, Long: byte;
begin
St1 := ''; St2 := ''; St3 := ''; aStr := Trim(aStr);
Long := Length(aStr); if Long <= Long1 then
begin
St1 := aStr; Exit end; Pos := Long1;
for i := 1 to Long1 + 1 do if aStr[i] = ' ' then Pos := i;
St1 := TrimRight(Copy(aStr, 1, Pos)); Delete(aStr, 1, Pos);
aStr := TrimLeft(aStr); Long := Length(aStr); if Long <= Long2 then
begin
St2 := aStr; Exit end; Pos := Long2;
for i := 1 to Long2 + 1 do if aStr[i] = ' ' then Pos := i;
St2 := TrimRight(Copy(aStr, 1, Pos)); St3 := Trim(Copy(aStr, Pos + 1, Long3))
end;

31.  Sortowanie StringGrida według kolumn.

typeTMoveSG = class(TCustomGrid); // dostęp do chronionej procedury MoveRow
{...}
procedure SortGridByCols(Grid: TStringGrid; ColOrder: array of Integer);
var i, j: Integer; Sorted: Boolean;

function Sort(Row1, Row2: Integer): Integer;
var C: Integer;
begin
C := 0;
Result := AnsiCompareStr(Grid.Cols[ColOrder[C]][Row1], Grid.Cols[ColOrder[C]][Row2]);
if Result = 0 then
begin
Inc(C); while (C <= High(ColOrder)) and (Result = 0) do
begin
Result := AnsiCompareStr(Grid.Cols[ColOrder[C]][Row1],
Grid.Cols[ColOrder[C]][Row2]); Inc(C); end; end;
end;
begin
if SizeOf(ColOrder) div SizeOf(i) < > Grid.ColCount then Exit;
for i := 0 to High(ColOrder) do
if (ColOrder[i] < 0) or (ColOrder[i] >= Grid.ColCount) then Exit;
j := 0; Sorted := False; repeat Inc(j);
with Grid do
for i := 0 to RowCount - 2 do if Sort(i, i + 1) > 0 then
begin
TMoveSG(Grid).MoveRow(i + 1, i); Sorted := False; end;
until Sorted or (j = 1000); Grid.Repaint;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{sortowanie zawartości dwóch i więcej kolumn - najpierw w
kolumnie 1następnie w kolumnie 2 itd}
SortGridByCols(StringGrid1, [1, 2, 0, 3, 4]);
end;

32.  Sortowanie w StringGrid - inna wersja.

procedure SortStringGrid(var GenStrGrid: TStringGrid; ThatCol: Integer);
const TheSeparator = '@'; // Definicja separatora
var CountItem, I, J, K, ThePosition: integer; MyList: TStringList;
MyString, TempString: string;
begin
CountItem := GenStrGrid.RowCount; // odczyt liczby wierszy StringGrid
MyList := TStringList.Create; //tworzenie listy
MyList.Sorted := False;
try begin
for I := 1 to (CountItem - 1) do
MyList.Add(GenStrGrid.Rows[I].Strings[ThatCol] + TheSeparator +
GenStrGrid.Rows[I].Text); Mylist.Sort; //Sortuj listę
for K := 1 to Mylist.Count do
begin
MyString := MyList.Strings[(K - 1)]; //bierze łańcuch z linii (K – 1)
//szukaj pozycji separatora w łańcuchu
ThePosition := Pos(TheSeparator, MyString);
TempString := '';
{Eliminacja tekstu w kolumnie, na której mamy posortowanego StringGrida}
TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
MyList.Strings[(K - 1)] := ''; MyList.Strings[(K - 1)] := TempString;
end;
for J := 1 to (CountItem - 1) do
GenStrGrid.Rows[J].Text := MyList.Strings[(J - 1)];
end;
finally MyList.Free; end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
// Sortuje StringGrid1 w drugiej kolumnie
SortStringGrid(StringGrid1, 1);
end;

33.  Sortowanie kolumn w StringGrid -wersja 3

type TStringGridExSortType = (srtAlpha, srtInteger, srtDouble);

procedure GridSort(SG: TStringGrid; ByColNumber, FromRow, ToRow: integer;
SortType: TStringGridExSortType = srtAlpha);
var Temp: TStringList;

function SortStr(Line: string): string;
var RetVar: string;
begin
case SortType of srtAlpha: Retvar := Line;
srtInteger: Retvar := FormatFloat('000000000', StrToIntDef(trim(Line), 0));
srtDouble:
try Retvar := FormatFloat('000000000.000000', StrToFloat(trim(Line)));
except RetVar := '0.00'; end; end; Result := RetVar;
end;

// rekurencyjne QuickSort
procedure QuickSort(Lo, Hi: integer; CC: TStrings);
procedure Sort(l, r: integer);
var i, j: integer; x: string;
begin
i := l; j := r; x := SortStr(CC[(l + r) div 2]);
repeat
while SortStr(CC[i]) < x do inc(i);
while x < SortStr(CC[j]) do dec(j); if i <= j then
begin
Temp.Assign(SG.Rows[j]); // zamiana miejscami 2 linie
SG.Rows[j].Assign(SG.Rows[i]); SG.Rows[i].Assign(Temp);
inc(i); dec(j); end; until i > j; if l < j then sort(l, j);
if i < r then sort(i, r); end;
begin {quicksort}
;
Sort(Lo, Hi);
end;

begin
Temp := TStringList.Create; QuickSort(FromRow, ToRow, SG.Cols[ByColNumber]);
Temp.Free;
end;

34.  Przeciąganie i upuszczanie elementow w TListView

{ ListView1.DragMode := dmAutomatic }

procedure TForm1.ListView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var DragItem, DropItem, CurrentItem, NextItem: TListItem;
begin
if Sender = Source then with TListView(Sender) do
begin
DropItem := GetItemAt(X, Y); CurrentItem := Selected;
while CurrentItem < > nil do
begin
NextItem := GetNextItem(CurrentItem, SdAll, [IsSelected]);
if DropItem = nil then DragItem := Items.Add
else
DragItem := Items.Insert(DropItem.Index); DragItem.Assign(CurrentItem);
CurrentItem.Free; CurrentItem := NextItem; end; end;
end;

procedure TForm1.ListView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Sender = ListView1;
end;

35.  Przeciąganie i upuszczanie pozycji z RichEdit do ListBoxa.

var Form1: TForm1; richcopy: string; transfering: boolean;

implementation
{$R *.DFM}

procedure TForm1.RichEdit1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if length(richedit1.seltext) > 0 then begin
richcopy:=richedit1.seltext; transfering:=true; end; //seltext
end;

procedure TForm1.ListBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if transfering then begin
transfering:=false; listbox1.items.add(richcopy); end; //transfering
end;

36.  Zmiana pozycji elementów ListBox z pomocą Drag and Drop.

{ ListBox1.DragMode := dmAutomatic }

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
with (Sender as TListBox) do
Items.Move(ItemIndex,ItemAtPos(Point(x,y),True));
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := (Sender=Source);
end;

37.  Przenoszenie elementów (węzłów) w TTreeView.

// Procedura przenosi node(rozdziały) razem z subnodes (podrozdziałami).
Procedure TForm1.MoveNode(TargetNode, SourceNode : TTreeNode);
var nodeTmp : TTreeNode; i : Integer;
begin
with TreeView1 do
begin
nodeTmp := Items.AddChild(TargetNode,SourceNode.Text);
for i := 0 to SourceNode.Count -1 do
begin
MoveNode(nodeTmp,SourceNode.Item[i]); end; end;
end;

procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var TargetNode, SourceNode : TTreeNode;
begin
with TreeView1 do
begin
TargetNode := GetNodeAt(X,Y); // pokaz węzeł docelowy
SourceNode := Selected; if (TargetNode = nil) then
begin
EndDrag(False); Exit; end;
MoveNode(TargetNode,SourceNode); SourceNode.Free; end;
end;

procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Sender = TreeView1) then // jak TRUE to akceptacja pozycji
begin
Accept := True; end;
end;

38.  Pisanie długich podpowiedzi na pasku StatusBar.

Przykład pokazuje na pasku StatusBar podpowiedzia gdy kursor myszy znajdzie się na obiekcie - tu buttony:

public
procedure DoShowHint(Sender: TObject);
...
procedure TForm1.DoShowHint(Sender: TObject);
begin
StatusBar1.SimpleText := Application.Hint;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnHint := DoShowHint;
Button1.Hint := 'Button 1 | To jest button pierwszy';
Button2.Hint := 'Button 2 | Ten przycisk jest buttonem 2';
Button3.Hint := 'Button 3 | A ten klawisz to oczywiscie button 3';
Form1.ShowHint := true;
end;
Symbol "|" pozwala dzielić dwie wskazówki: jedna pojawia się przy buttonie na żółtym tle a ta poza tym symbolem będzie widoczna na pasku StatusBar.

39.  Podpowiedzi nad elementami w kształcie balonu.

uses Commctrl;
{....}
const TTS_BALLOON = $40; TTM_SETTITLE = (WM_USER + 32);
var
hTooltip: Cardinal; ti: TToolInfo; buffer: array[0..255] of char;
{....}
procedure CreateToolTips(hWnd: Cardinal);
begin
hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or
TTS_BALLOON,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
if hToolTip < > 0 then
begin
SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
ti.cbSize := SizeOf(TToolInfo); ti.uFlags := TTF_SUBCLASS; ti.hInst := hInstance;
end; end;

procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer; Text, Title: PChar);
var Item: THandle; Rect: TRect;
begin
Item := hWnd; if (Item < > 0) and (GetClientRect(Item, Rect)) then
begin
lpti.hwnd := Item; lpti.Rect := Rect; lpti.lpszText := Text;
SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
FillChar(buffer, SizeOf(buffer), #0); lstrcpy(buffer, Title);
if (IconType > 3) or (IconType < 0) then
IconType := 0;
SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
end; end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;

{typ ikony to: 0 - bez ikony, 1 - Information, 2 - Warning, 3 - Error}

40.  Wyprowadzenie tekstu na formie pod katem.

procedure TForm1.Button1Click(Sender: TObject);
var logfont: TLogFont; font: Thandle; count: integer;
begin
LogFont.lfheight := 20; logfont.lfwidth := 20; logfont.lfweight := 750;
LogFont.lfEscapement := -200; logfont.lfcharset := 1;
logfont.lfoutprecision := out_tt_precis; logfont.lfquality := draft_quality;
logfont.lfpitchandfamily := FF_Modern; font := createfontindirect(logfont);
Selectobject(Form1.canvas.handle, font);
SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
SetBKmode(Form1.canvas.handle, transparent);
for count := 1 to 100 do
begin
canvas.textout(Random(form1.width), Random(form1.height), 'Hello');
SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random (255)));
end; Deleteobject(font);
end;

41.  TDateTimePicker w StringGridzie.

unit Unit1;

interface

uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, ComCtrls;

type TForm1 = class(TForm)
StringGrid1: TStringGrid;
DateTimePicker1: TDateTimePicker;
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean);
procedure FormCreate(Sender: TObject);
procedure StringGrid1Exit(Sender: TObject);
procedure DateTimePicker1Exit(Sender: TObject);
end;

var Form1: TForm1;
implementation
{$R *.dfm}

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
var D: TDateTime;
begin
DateTimePicker1.Visible := True;
DateTimePicker1.BoundsRect := StringGrid1.CellRect(ACol, ARow);
D := DateTimePicker1.DateTime;
TryStrToDateTime(StringGrid1.Cells[ACol, ARow], D);
DateTimePicker1.DateTime := D; DateTimePicker1.SetFocus;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
DateTimePicker1.Parent := StringGrid1;
DateTimePicker1.Visible := False;
DateTimePicker1.OnExit := DateTimePicker1Exit;
StringGrid1.OnSelectCell := StringGrid1SelectCell;
end;

procedure TForm1.StringGrid1Exit(Sender: TObject);
begin
DateTimePicker1.Visible := False;
end;

procedure TForm1.DateTimePicker1Exit(Sender: TObject);
begin
with StringGrid1 do
Cells[Col, Row] := DateTimeToStr(DateTimePicker1.DateTime);
end;

end.

42.  Drukowanie StringGrida.

uses Printers;

procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
var X1, X2: Integer; Y1, Y2: Integer; TmpI: Integer; F: Integer; TR: TRect;
begin
Printer.Title := sTitle; Printer.BeginDoc; Printer.Canvas.Pen.Color := 0;
Printer.Canvas.Font.Name := 'Times New Roman';
Printer.Canvas.Font.Size := 12; Printer.Canvas.Font.Style := [fsBold, fsUnderline];
Printer.Canvas.TextOut(0, 100, Printer.Title);
for F := 1 to sGrid.ColCount - 1 do
begin
X1 := 0; for TmpI := 1 to (F - 1) do X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
Y1 := 300; X2 := 0; for TmpI := 1 to F do
X2 := X2 + 5 * (sGrid.ColWidths[TmpI]); Y2 := 450;
TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.Font.Style := [fsBold]; Printer.Canvas.Font.Size := 7;
Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
Printer.Canvas.Font.Style := [];
for TmpI := 1 to sGrid.RowCount - 1 do
begin
Y1 := 150 * TmpI + 300; Y2 := 150 * (TmpI + 1) + 300; TR := Rect(X1, Y1, X2 - 30, Y2);
Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
end; end; Printer.EndDoc;
end;

//przykład
procedure TForm1.Button1Click(Sender: TObject);
begin
PrintGrid(StringGrid1, 'Print Stringgrid');
end;

43.  Odczyt napędu CD-ROM w komputerze - warianty.

Wariant 1:
var DriveType: UInt;
DriveType := GetDriveType(PChar('F:\'));
if DriveType = DRIVE_CDROM then ShowMessage('Napęd F');

Wariant 2:
function GetFirstCDROM: string; {zwraca literę pierwszego napedu CD lub pusty łancuch}
var w: dword; Root: string; i: integer;
begin
w := GetLogicalDrives; Root := '#:\'; for i := 0 to 25 do
begin
Root[1] := Char(Ord('A') + i); if (W and (1 shl i)) > 0 then
if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
begin
Result := Root[1]; exit; end; end; Result := '';
end

Wariant 3:
function GetFirstCDROMDrive: char;
var drivemap, mask: DWORD; i: integer; root: string;
begin
Result := #0; root := 'A:\'; drivemap := GetLogicalDrives; mask := 1;
for i := 1 to 32 do
begin
if (mask and drivemap) < > 0 then
if GetDriveType(PChar(root)) = DRIVE_CDROM then
begin
Result := root[1]; Break; end; mask := mask shl 1; Inc(root[1]); end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(GetFirstCDROMDrive);
end;

Wariant 4:
procedure TForm1.Button1Click(Sender: TObject);
var w: dword; Root: string; i: integer;
begin
w := GetLogicalDrives; Root := '#:\'; for i := 0 to 25 do
begin
Root[1] := Char(Ord('A') + i); if (W and (1 shl i)) > 0 then
if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
Form1.Label1.Caption := Root; end;
end;

44.  Bitmapa na pulpicie komputera.

procedure TForm1.Button1Click(Sender: TObject);
var Picture: TPicture; Desktop: TCanvas; X, Y: Integer;
begin
Picture := TPicture.Create; Desktop := TCanvas.Create; // tworzenie objektu
Picture.LoadFromFile('bitmap1.bmp'); // ładuj obraz
Desktop.Handle := GetWindowDC(0); // get DC of desktop
X := 100; Y := 100; //pozycja bitmapy
Desktop.Draw(X, Y, Picture.Graphic);//rysuj obraz
ReleaseDC(0, Desktop.Handle);
Picture.Free; Desktop.Free;
end;

45.  Jak zobaczyć hasło ukryte za gwiazdkami?

procedure TForm1.Timer1Timer(Sender: TObject);
varWnd : HWND;lpClassName: array [0..$FF] of Char;
begin
Wnd := WindowFromPoint(Mouse.CursorPos);
GetClassName (Wnd, lpClassName, $FF);
if ((strpas(lpClassName) = 'TEdit') or (strpas(lpClassName) = 'EDIT')) then
PostMessage (Wnd, EM_SETPASSWORDCHAR, 0, 0);
end;