Obsługa wybranych algorytmów

1.   Niszczenie pozycji z listy


Usuwając pozycję z listy należy przeindeksować listę aby w kolejnym kroku nie było w niej przekłamań. Usuwając pozycję [i] jej wartość przyjmuje pozycja będąca dotychczas jako [i + 1] . Nie należy zatem robić jak niżej:
with Listbox1.Items do
for i := 0 to Count - 1 do begin   if Strings[i] = 'Deleteme' then Delete(i);
end;

//ale uzyskiwać dostęp do listy od końca jak to...
with Listbox1.Items do
for i := Count - 1 downto 0 do begin   if Strings[i] = 'Deleteme' then Delete(i);
end;

2.  Losowa generacja stringów


losowa generacja zawężona do: stringi 6-cio znakowe; pierwsze 3 znaki to litery A..Z a kolejne to cyfry 0..9. Za pomocą funkcji:

function RandomString(expr: string): string;
{ 1: A..Z 2: a..z 4: 0..9 if you want (A..Z, a..z) use 3;
(A..Z, a..z, 0..9) use 7 (A..Z, 0..9) use 5 (a..z, 0..9) use 6
i.e. RandomString('123'); to generate a 3 letters random string... }
var i: Byte; s: string; v: Byte;
begin
Randomize; SetLength(Result, Length(expr));
for i:=1 to Length(expr) do begin
s:='';   try   v:=StrToInt(Expr[i]);
except v:=0; end;
if (v-4) > = 0 then begin   s:=s+'0123456789';   dec(v, 4);   end;
if (v-2) > = 0 then begin   s:=s+'abcdefghijklmnopqrstuvwxyz';   dec(v, 2);   end;
if (v-1) > = 0 then   s:=s+'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
Result[i]:=s[Random(Length(s)-1)+1];
end;   end;

3.   Specjalne funkcje wycinania spacji - #32


// ta funkcja określa spacje w stringu, które mają byc usunięte z lewej innych znaków..
Function SpLTrim( What : String; WhatChar : Char = #32 ) : String;
Var IdX : Integer;
Begin
Result := What;   If ( Length( What ) > 0 ) Then Begin
For IdX := 1 To Length( What ) Do
If ( What[ IdX ] < > WhatChar ) Then   Break;
If ( IdX > 1 ) Then   Result := Copy( What, IdX, MaxInt );
End; End;

//ta określa spacje po prawej....
Function SpRTrim( What : String; WhatChar : Char = #32 ) : String;
Var IdX : Integer;
Begin
Result := What;   If ( Length( What ) > 0 ) Then Begin
For IdX := Length( What ) DownTo 1 Do
If ( What[ IdX ] < > WhatChar ) Then   Break;
If ( IdX > 1 ) Then   Result := Copy( What, 1, IdX );
End; End;

//a ta usuwa poprzednio określone...
Function SpTrim( What : String; WhatChar : Char = #32 ) : String;
Begin
Result := SpLTrim( SpRTrim( What, WhatChar ), WhatChar );
End;

4.   Powiększanie TDateTime o dni robocze w danym tygodniu


w przykładzie poniedziałek da 1 ... piątek da 4 by dopiero w kolejny poniedziałek była 1-ka.
function IncWeekDay(InDate: TDateTime; Increment: integer = 1): TDateTime;
begin
if Increment < 0 then begin   {Positive Increment}
if DayofWeek(InDate) = 7 then   InDate := InDate - 1;
result := InDate + ((Trunc(((Increment - (6 - DayOfWeek(InDate)))/5) + 0.8) * 2) + Increment);
end else if Increment < 0 then begin   {Negative Increment}
if DayofWeek(InDate) = 1 then   InDate := InDate + 1;
result := InDate + ((Trunc(((Increment - (2 - DayOfWeek(InDate)))/5) - 0.8) * 2) + Increment);
end   else begin   {No Increment}
result := InDate;
end;   end;

5.   Odczytanie daty utworzenia, modyfikacji i ostatniego dostępu do pliku


procedure TForm1.OdczytajDaty;
var sr: TSearchRec; u,m,d: TDateTime; localFileTime: TFileTime; systemTime: TSystemTime;
begin
if FindFirst('C:\sciezka\plik.roz',faAnyFile,sr)=0 then begin
FileTimeToLocalFileTime(sr.FindData.ftCreationTime,localFileTime);
FileTimeToSystemTime(localFileTime,systemTime);
u:=SystemTimeToDateTime(systemTime);
FileTimeToLocalFileTime(sr.FindData.ftLastWriteTime,localFileTime);
FileTimeToSystemTime(localFileTime,systemTime);
m:=SystemTimeToDateTime(systemTime);
FileTimeToLocalFileTime(sr.FindData.ftLastAccessTime,localFileTime);
FileTimeToSystemTime(localFileTime,systemTime);
d:=SystemTimeToDateTime(systemTime);
end;   FindClose(sr);
ShowMessage('Data utworzenia pliku to: '+DateTimeToStr(u));
ShowMessage('Data ostatniej modyfikacji pliku to: '+DateTimeToStr(m));
ShowMessage('Data ostatniego dostępu do pliku to: '+DateTimeToStr(d));
end;

5.   Zapisywanie ustawień programu


uses IniFiles

procedure TForm1.ZapiszUstawienia;
var ini: TIniFile; b: Boolean; n: Integer; s: String; d: TDateTime; f: Double;
begin
b:=False; n:=99; s:='jaki¶ tekst'; d:=Now; f:=3.14;
ini:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'ustawienia.ini');
ini.WriteString('naglowek','s',s);   ini.WriteBool('naglowek','b',b);
ini.WriteInteger('naglowek','n',n);   ini.WriteDateTime('naglowek','d',d);
ini.WriteFloat('naglowek','f',f);   ini.UpdateFile;   ini.Free;
end;

6.   Wczytywanie ustawień programu


uses IniFiles

procedure TForm1.WczytajUstawienia;
var ini: TIniFile; b: Boolean; n: Integer; s: String; d: TDateTime; f: Double;
begin
ini:=TIniFile.Create(ExtractFilePath(Application.ExeName)+'ustawienia.ini');
b:=ini.ReadBool('naglowek','b',True);   n:=ini.ReadInteger('naglowek','n',0);
s:=ini.ReadString('naglowek','s','');   d:=ini.ReadDateTime('naglowek','d',Now);
f:=ini.ReadFloat('naglowek','f',0);   ini.Free;
end;

7.   Odczyt ścieżki katalogu Windows i System


Do uzyskiwania takiej informacji służą funkcje GetWindowsDirectory i GetSystemDirectory.
var WDir : array[0..255] of char;
begin
GetSystemDirectory(WDir, SizeOf(WDir));   Label1.Caption := WDir;
Żeby uzyskać ścieżkę katalogu System należy po prostu zamiast GetWindowsDirectory podstawić GetSystemDirectory.
Istnieje także funkcja GetTempPath - oto jak z niej korzystać:
var Buffer: array[0..255] of char;
begin
GetTempPath(SizeOF(Buffer), Buffer); ShowMessage(Buffer);
end;

8.   Jak zablokować ponowne uruchomienie programu?


var hM : HDC;
begin
hM:=CreateFileMapping(THANDLE($FFFFFFFF),nil, PAGE_READONLY,0,32,'ApplicationTestMap');
if GetLastError=ERROR_ALREADY_EXISTS then begin
ShowMessage('Nie można uruchomić tego samego programu');
Application.Terminate;   CloseHandle(hM);   end;
Z tym, że ciąg "ApplicationTestMap" musi być unikalny dla całego systemu - dwie aplikacje nie mogę wykorzystać tego samego parametru.

9.   Jak przenieść, skasować, zmienić nazwę katalogu?


Najlepiej jest skorzystać z modułu SHELLAPI. Oto przykład:
uses ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
var R : TSHFileOpStructA;
begin
with R do begin   Wnd:=Handle;   // oznaczenie uchwytu
wFunc:=FO_COPY;   // opcja
pFrom:='c:\moj';   // z katalogu
pTo:='c:\dokumenty\moj';   // do katalogu...
fFlags:=FOF_NOCONFIRMMKDIR;   end;
if SHFileOperation(R) < > 0 then ShowMessage('Błąd podczas kopiowania')   end;
Zamiast parametru FO_COPY możesz użyć:
FO_DELETE - kasuje wFrom
FO_RENAME - zmienia nazwę z wFrom do w wTo
FO_MOVE - przenosi z wFrom do wTo
Można to wykorzystać do operacjami okienek Windowsa oraz z ProgressBar.

10.   Jak utworzyć skrót do programu na pulpicie lub w menu start


W przykładzie tworzony jest skrót do programu Notepad.

uses ShlObj, ActiveX, ComObj, Registry;

procedure TForm1.Button1Click(Sender: TObject);
var MyObject:IUnknown; MySLink:IShellLink; MyPFile:IPersistFile; FileName:String;
Directory:String; WFileName:WideString; MyReg:TRegIniFile;
begin
MyObject:=CreateComObject(CLSID_ShellLink);
MySLink:=MyObject as IShellLink;   MyPFile:=MyObject as IPersistFile;
FileName:='C:\Windows\NOTEPAD.EXE';
with MySLink do begin
SetPath(PChar(FileName));   SetWorkingDirectory(PChar(ExtractFilePath(FileName)));
end;
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\'+ 'CurrentVersion\Explorer');
// Poniższe dodaje skrót do desktopu
Directory := MyReg.ReadString('Shell Folders','Desktop','');

// A to do menu Start
Directory := MyReg.ReadString('Shell Folders','Start Menu','')+ '\Microspace';
CreateDir(Directory);
WFileName := Directory+'\Notatnik.lnk';   MyPFile.Save(PWChar(WFileName),False);   MyReg.Free;
end;

11.   Jak usunąć ( odinstalować ) aplikację?


W przykładzie aplikacja usuwa samego siebie. W tym celu stworzony zostanie program ( ! ) który usunie pliki naszego programu. Program zostanie stworzony w katalogu Windows\Temp, gdyż ten katalogu jest często opróżniany, a nasz program zajmował będzie tylko 18 bajtów! Tak, to będzie program dosowy z rozszerzeniem *.bat. A więc oto kod:

var TF: TextFile;
begin
PostMessage(Handle, wm_Quit, 0, 0);   // zamkniecie naszej aplikacji
AssignFile(TF, 'C:\Windows\Temp\kill.bat');   // zapisz plik
Rewrite(TF); Writeln(TF, ':kill');
Writeln(TF, 'cd ' + ParamStr(0));   Writeln(TF, 'del ' + ExtractFileName(ParamStr(0)));
Writeln(TF, 'if exist ' + ExtractFileName(ParamStr(0))+ ' goto kill');
CloseFile(TF);

// uruchom program
WinExec('C:\Windows\Temp\kill.bat', sw_Hide);
end;

12.   Jak pozmieniać znaki w określonym miejscu pliku?


Należy skorzystać ze strumieni. Procedura obejmie swoim zasięgiem 500 znaków zaczynając od 100 bajtów pliku:

procedure TForm1.ChangeCharsClick(Sender: TObject);
var F : TFileStream; Buff : array[0..1024] of char; iMuch, i : Integer;
begin
F := TFileStream.Create('C:\Scandisk.log', fmOpenReadWrite);
try F.Position := 200;   // ustaw na pozycji
iMuch := F.Read(Buff, 500);   // odczytaj znaki
for I := 0 to iMuch do if Buff[i] = ' ' then   Buff[i] := '_';   // zastap spacje znakiem _

F.Position := 100;  // ustaw na poprzedniej pozycji
F.Write(Buff, iMuch);   // zapisz nowa wartość
finally   F.Free;   end;
end;

13.   W jaki sposób sprawdzić ile miejsca zajmują wszystkie pliki w danym katalogu?


Procedura podaje ilość miejsca w kB:
function IsSlash(const sText: String) : String;
begin   { sprawdzenie, czy na koncu jest znak \ }
if sText[Length(sText)] < > '\' then   Result := sText + '\' else Result := sText;
end;

procedure TMainForm.Button1Click(Sender: TObject);
var SR: TSearchRec; Found : Integer; Size : Int64; { < -- dla duzych plikow - ten typ zmiennej }
begin
Size := 0;   // zeruj
{ szukaj plikow ( wszystkiech ) w danym kataogu }
Found := FindFirst(IsSlash(Edit1.Text) + '*.*', faAnyFile, SR);
while (Found = 0) do begin   Size := Size + (SR.Size);
Found := FindNext(SR);   // szukaj dalej
end; FindClose(SR);   { dzielenie przez 1024, aby otrzymac liczbe kilobajtow }
Size := Size div 1024;   ShowMessage('Katalog: ' + Edit1.Text + ' zajmuje: ' + IntToStr(Size) + ' kB');
end;

14.   Jak zmienić datę modyfikacji pliku?


Na początek procedura:
procedure FSetFileTime(FFile : String; Data : String);
var Age, FHandle: integer; LocalFileTime, FileTime: TFileTime; F: File;
begin
if FileExists(FFile) then begin
AssignFile(F, FFile);   Reset(F);
try   Age := DateTimeToFileDate(StrToDateTime(Data));
FHandle := TFileRec(F).Handle;
DosDateTimeToFileTime(LongRec(Age).Hi, LongRec(Age).Lo, LocalFileTime);
LocalFileTimeToFileTime(LocalFileTime, FileTime);
SetFileTime(FHandle, nil, nil, @FileTime);   {ustawia datę ostatniej modifikacji }
finally   CloseFile(F);   end; end else
ShowMessage('Błąd! Plik nie istnieje!');
end;

//Teraz żeby zmienić datę piszesz:
FSetFileTime('C:\Delphi.zip', '01-01-01');   // W tym wypadku na 01-01-2001 r.

15.   Jak przechwycić adres WWW wpisany w przeglądarce?


Function 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;

function GetURL:string;
var ie,toolbar,combo, comboboxex,edit, worker,toolbarwindow: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);
toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);   result := GetText(edit);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
shomessage(GetURL);
end;

16.   Jak podzielić słowa wg. spacji?


Oto procedura:
procedure DivWords(Value : String; var Words : TStrings);
var i : Integer; iPos : Integer; Word : String;
begin
Insert(' ', Value, 1);   for I := 0 to Length(Value) -1 do begin
if Value[i] = ' ' then begin   iPos := I;
repeat Inc(iPos);   Word := Copy(Value, i, iPos);
until Word[iPos] = ' ';   Words.Add(Word);   end; end;
end;

//A to sposób wykorzystania tej procedury:
var Words : TStrings;
begin
Words := TStringList.Create;   DivWords('serwis o programowaniu', Words);
ShowMessage(Words.Text);   Words.Free;
end;

17.   Wylogowanie, wyłączenie oraz ponowne uruchomienie komputera


function TForm1.MyExitWindows(RebootParam: Longword): Boolean;
var tTokenHd: THandle; tTokenPvg: TTokenPrivileges; cbtpPrevious: DWord; rtTokenPvg: TTokenPrivileges; pcbtpPreviousRequired: DWord; tpResult: Boolean;
begin
if Win32Platform=VER_PLATFORM_WIN32_NT then begin
tpResult:= OpenProcessToken (GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, tTokenHd);
if tpResult then begin
tpResult:=LookupPrivilegeValue(nil,'SeShutdownPrivilege',tTokenPvg.Privileges[0].Luid);
tTokenPvg.PrivilegeCount:=1;   tTokenPvg.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
cbtpPrevious:=SizeOf(rtTokenPvg);   pcbtpPreviousRequired:=0;
if tpResult then
Windows.AdjustTokenPrivileges (tTokenHd,False, tTokenPvg, cbtpPrevious, rtTokenPvg, pcbtpPreviousRequired);
end; end;   Result:=ExitWindowsEx(RebootParam,0);
end;

// uwaga: aby wylogować użytkownika należy wywołać procedurę
MyExitWindows(EWX_LOGOFF or EWX_FORCE);

// uwaga: aby wyłączyć komputer należy wywołać procedurę
MyExitWindows(EWX_POWEROFF or EWX_FORCE);

// uwaga: aby ponownie uruchomić komputer należy wywołać procedurę
MyExitWindows(EWX_REBOOT or EWX_FORCE);

18.   Wykrywanie adresu IP komputera


uses WinSock;

procedure TForm1.FormCreate(Sender: TObject);
var wVersionRequested: Word; wsaData: TWSAData;
begin
wVersionRequested:=MakeWord(1,1);   WSAStartup(wVersionRequested,wsaData);
end;

procedure TForm1.Button1Click(Sender: TObject);
var p: PHostEnt; s: array[0..128] of Char; p2: PChar;
begin
GetHostName(@s,128);   p:=GetHostByName(@s);   Caption:=iNet_ntoa(PInAddr(p^.h_addr_list^)^);
end;

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

// uwaga: adresy 0.0.0.0 oraz 127.0.0.1 oznaczają że komputer nie jest podłączony do sieci

19.   Lista tytułów, typów oraz uchwytów wszystkich otwartych okien


function EnumWindowsProc(wHandle: HWND): Boolean; StdCall; Export;
var title,className: array[0..128] of Char; sTitle,sClass,sLine: String;
begin
Result:=True;   GetWindowText(wHandle,title,128);
GetClassName(wHandle,className,128);   sTitle:=title;   sClass:=className;
if IsWindowVisible(wHandle) then begin
sLine:=sTitle+'/'+sClass+'/'+IntToHex(wHandle,4);   Form1.Listbox1.Items.Add(sLine);
end;   end;

wywołanie EnumWindows(@EnumWindowsProc,0);

uwaga: usuwając warunek IsWindowVisible(wHandle) otrzymamy listę wszystkich uruchomionych procesów, także tych ukrytych

20.   Jak uzyskac informacje o systemie ?


Istnieje cała grupa funckji WinAPI która to umozliwia, oto krotki opis.

InitiateSystemShutdown - rozpoczyna zamykanie systemu
AbortSystemShutdown - anuluje zamykanie systemu
ExpandEnvironmentStrings - pobiera zmienne srodowiskowe
GetComputerName - nazwa komputera
GetKeyboardType - typ klawiatury
GetSysColor - podaje kolor dla wybranego elementu systemu
GetSystemDirectory - katalog systemowy
GetSystemInfo - zwraca strukture zawierajaca informacje o architekturze systemu (typ procesora)
GetSystemMetrics - masa informacji na temat systemu, np. jak zostal uruchomiony itp.
GetThreadDesktop - zwraca uchwyt pulpitu przypisanego do podanego watku
GetUserName - zwraca nazwe uzytkownika
GetVersion - czy Windows NT czy 95
GetVersionEx - rozszerzona informacja o versji systemu
GetWindowsDirectory - katalog WINDOWS
SetComputerName - ustawia nazwe komputera jaka bedzie obowiazywac po restarcie
SetSysColors - ustawia kolor podanych elementow systemu
SystemParametersInfo - pobiera lub ustawia rozne informacje systemowe.

21.   Jak uruchomic program przy starcie systemu ?


Jeżeli ta operacja ma być niewidoczna to należy wpisać sciezke dostępu do odpowiedniego klucza w rejestrze.

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run
oraz
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce

22.   Jak sprawdzić jaki typ danych jest w schowku?


Należy skorzystać z modułu Clipbrd; Następnie możesz sprawdzić, czy w schowku jest tekst, bitmapa itp:

var B : Tbitmap;
begin
try   try  if Clipboard.HasFormat(CF_TEXT) then ShowMessage( ClipBoard.AsText);
if Clipboard.HasFormat(CF_BITMAP) then
B := Tbitmap.Create;   B.Assign(ClipBoard);   B.Width := 120;   B.Height := 100;
finally   B.Free;   end;
except   raise Exception.Create( 'Ne ma nic w schowku!');
end;

//CF_TEXT - tekst.   CF_BITMAP - bitmapa Windows;
// CF_PICTURE - zdjęcie klasy TPicture.   CF_METAFILEPICT - metaplik;

23.   Jak zapisać, odczytać wartość binarną z rejestru?


Zapisywanie odbywa się podobnie jak zapis z tym, że zamiast WriteBinaryData piszesz ReadBinary.

var Rejestr : TRegistry; Zmienna : String;
begin
Zmienna := 'www.programowanie.of.pl';   Rejestr:=TRegistry.Create;
Rejestr.OpenKey('Software\Pad',True);
Rejestr.WriteBinaryData('Nazwa wartości',Zmienna,SizeOf(Zmienna));
Rejestr.Free;
end;   // Nie zapomnij dodać do listy uses słowo: Registry;

24. Skróty do aplikacji - jak programowo utworzyć skrót


function createshortcut(const cmdline, args, workdir, linkfile: string): ipersistfile;
var myobject: iunknown; myslink: ishelllink; mypfile: ipersistfile; widefile: widestring;
begin
myobject := createcomobject(clsid_shelllink);
myslink := myobject as ishelllink; mypfile := myobject as ipersistfile;
with myslink do
begin
setpath(pchar(cmdline)); setarguments(pchar(args));
setworkingdirectory(pchar(workdir));
end;
widefile := linkfile; mypfile.save(pwchar(widefile), false); result := mypfile;
end;

procedure createshortcuts;
var directory, execdir: string;
myreg: treginifile;
begin
myreg := treginifile.create( 'softwaremicrosoftwindowscurrentversionexplorer');
execdir := extractfilepath(paramstr(0));
directory := myreg.readstring('shell folders', 'programs', '') + '' + programmenu;
createdir(directory); myreg.free;
createshortcut(execdir + 'autorun.exe', '', execdir, directory + 'demonstration.lnk');
createshortcut(execdir + 'readme.txt', '', execdir, directory + 'installation notes.lnk');
createshortcut(execdir + 'winsysivi_nt95.exe', '', execdir, directory + 'install intel video interactive.lnk');
end;

Ogólnie rzecz biorąc, bardziej poprawne będzie zastosowanie procedury createshortcuts Win32API:: getspecialfolderlocation z parametrem (csidl_programs w przypadku folderu "Programy" lub csidl_desktop dla "desktop").

25. Jak otworzyć utworzyć skrót metodą dialogu.


uses registry, shellapi;

function launch_createshortcut_dialog(directory: string): boolean;
var reg: tregistry; cmd: string;
begin
result := false; reg := tregistry.create;
try
reg.rootkey := hkey_classes_root;
if reg.openkeyreadonly('.lnkshellnew') then
begin
cmd := reg.readstring('command'); cmd := stringreplace(cmd, '%1', directory, []);
result := true; winexec(pchar(cmd), sw_shownormal); end
finally reg.free; end;
end;

{example}
procedure tform1.button1click(sender: tobject);
begin
launch_createshortcut_dialog('c:temp');
end;

26. Jak można uruchomić plik lnk (plik skrótu).


procedure tform1.button1click(sender: tobject);
begin
shellexecute(handle, nil, 'c:windowsstart menudelphidelphi6.lnk',
nil, nil, sw_shownormal);
end;

27. Usuwanie plików przy użyciu masek typu: c: temp *. zip c: temp *.*


Procedure ZapFiles(vMasc:String);
//pliki o zadanych maskach w danej ścieżce zostaną usunięte
Var Dir : TsearchRec; Erro: Integer;
Begin
Erro := FindFirst(vMasc,faArchive,Dir);
While Erro = 0 do Begin
DeleteFile( ExtractFilePAth(vMasc)+Dir.Name );
Erro := FindNext(Dir); End; FindClose(Dir);
End;

28. Jak umieścić ikonę na pulpicie?


implementation

uses comobj, shlobj, activex;

procedure createshortcut(const filepath, shortcutpath, description, params: string);
var obj: iunknown; isl: ishelllink; ipf: ipersistfile;
begin
obj := createcomobject(clsid_shelllink);
isl := obj as ishelllink; ipf := obj as ipersistfile;
with isl do
begin
setpath(pchar(filepath)); setarguments(pchar(params));
setdescription(pchar(description));
end;
ipf.save(pwchar(widestring(shortcutpath)), false);
end;

29. Jak uzyskać dostęp do ikony na pulpicie?


Wystarczy, aby uzyskać uchwyt do sterowania. przykład:

function getdesktoplistviewhandle: thandle;var s: string;
begin
result := findwindow('progman', nil);
result := getwindow(result, gw_child); result := getwindow(result, gw_child);
setlength(s, 40); getclassname(result, pchar(s), 39);
if pchar(s) < > 'syslistview32' then result := 0;
end;

Po tym, jak uzyskano uchwyt to można przy pomocy API umiescić ikonę w ListView lub przenieść w inne miejsce Pulpitu, np, za pomocą kodu - SendMessage (getdesktoplistviewhandle, lvm_align, lva_alignleft, 0); - rozmiescic ikonę po lewej stronie Pulpitu.

30. Jak pokazać ikony związane z typem pliku?


Za pomocą funkcji extractassociatedicon() shellapi. Przykład:
uses shellapi;

procedure tform1.button1click(sender: tobject);
var icon : hicon; iconindex : word;
begin
iconindex := 1;
icon := extractassociatedicon(hinstance, application.exename, iconindex);
drawicon(canvas.handle, 10, 10, icon);
end;

31. Jak uzyskać ikonę z pliku EXE. DLL. ICO?


Proces pozyskiwania ikon z tych plików jest identyczny.Jedyną różnicą jest to, że w pliku Ico może być przechowywana tylko jedna ikona, a w pliku Exe i. Dll kilka. Dla otrzymania ikon w module ShellApi jest funkcja:

function extracticon (inst: thandle; filename: PChar; iconindex: word): HICON; gdzie:
inst - wskaźnik do aplikacji wywołania funkcji
filename - nazwa pliku, z którego można pobrać ikony,
iconindex - liczba potrzebnych ikon.

Jeśli funkcja zwraca wartość inną niż zero, plik ma następujące ikony. W tym przykładzie, w komponencie image1 wyświetla się ikona programu w trakcie jego uruchomiania.

uses shellapi;
............
procedure tform1.formcreate(sender: tobject);
var a: array [0..78] of char;
begin
{pobierz nazwę uruchomionego pliku}
strpcopy(a, paramstr(0)); {wyświetl jego ikonę}
image1.picture.icon.handle := extracticon(hinstance, a, 0);
end;

32. Wyciąg ikony z plików EXE / DLL- inne wersja


var myicon: ticon;
begin
myicon := ticon. create;
try myicon.handle := extracticon(hinstance, 'myprog.exe', 0)
{tu np, można zapisać ikonę do pliku, dodac do Image lub ListView lub coć innego}
finally myicon.free; end;
end;

33. Wyciąg ikony z EXE ikony do TImage - jeszcze inna wersja


uses shellapi;

procedure tform1.button1click(sender: tobject);
var iconindex: word; h: hicon;
begin
iconindex := 0;
h := extractassociatedicon(hinstance, 'c:windowsnotepad.exe', iconindex);
drawicon(form1.canvas.handle, 10, 10, h);
end;

34. Jak napisać aplikację, której plansza będzie stała przy różnych rozdzielczościach ekranu?


unit main;
interface
uses windows, messages, sysutils, classes, graphics, controls, forms, dialogs, stdctrls;

type tform1 = class(tform)
button1: tbutton;
edit1: tedit;
procedure button1click(sender: tobject);
procedure formcreate(sender: tobject);
private { private declarations }
{daje komunikat o zmianie rozdzielczości ekranu}
procedure wmdisplaychange(var message: tmessage); message wm_displaychange;
public { public declarations }
w, h: integer;
end;

var form1: tform1;
implementation
{$r *.dfm}

procedure tform1.button1click(sender: tobject);
begin
width := round(width * 1.5); height := round(height * 1.5); scaleby(150, 100)
end;

procedure tform1.wmdisplaychange(var message: tmessage);
begin
inherited;
width := round(width * loword(message.lparam) / w);
height := round(height * hiword(message.lparam) / h);
scaleby(loword(message.lparam), w);
w := screen.width; h := screen.height;
end;

procedure tform1.formcreate(sender: tobject);
begin
w := screen.width; h := screen.height;
end;

end.

35. Tekst 3D


Tak wywołanie: imgpaintcanvas(image3.canvas, '0', 10, 6, 4);

procedure tform1.imgpaintcanvas(thecanvas : tcanvas; thestring : string;
thefontsize, ucorner, lcorner : integer);
begin
thecanvas.brush.style := bsclear; thecanvas.font.style := [fsbold];
thecanvas.font.name := 'ms sans serif'; thecanvas.font.size := thefontsize;
thecanvas.font.color := clblack; thecanvas.textout(ucorner, lcorner, thestring);
thecanvas.font.color := clgray; thecanvas.textout(ucorner - 1, lcorner - 1, thestring);
thecanvas.font.color := clsilver; thecanvas.textout(ucorner - 2, lcorner - 2, thestring);
thecanvas.font.color := clblack; thecanvas.textout(ucorner - 3, lcorner - 3, thestring);
end;

36.   Pokaz aktualnego języka klawiatury komputera 2 wersje.


var Form1: TForm1; LAYOUT: String;

implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var RA: Array[0..$FFF] of Char;
begin
GetKeyboardLayoutName(RA) ;
Layout := StrPas(RA);
if Layout = '00000419' then showmessage(' To jest język ruski ' )
else
if Layout = '00000409' then showmessage(' A ten język to USA ' )
else showmessage(' To język to ani ruski ani angielski' ) ;
end;

//wersja druga
function WhichLanguage:string;
var ID:LangID; Language: array [0..100] of char;
begin
ID:=GetSystemDefaultLangID;
VerLanguageName(ID,Language,100);
Result:=String(Language);
end;

//a takie wywołanie...
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text:=WhichLanguage;
end;

//ponadto do takich celów można wykorzystać funkcję - GetUserDefaultLangID.

37.   Blokada przed ponownym uruchomieniem programu.


var hM : HDC;
begin
hM:=CreateFileMapping(THANDLE($FFFFFFFF),nil,
PAGE_READONLY,0,32,'AplikacjaJestOK');
if GetLastError=ERROR_ALREADY_EXISTS then begin
ShowMessage('Nie można uruchomić tego samego programu');
Application.Terminate;
CloseHandle(hM);
end;

Z tym, że ciąg "AplikacjaJestOk" musi być unikalny dla całego systemu - dwie aplikacje nie mogę wykorzystać tego samego parametru.

38. Odczyt folderów specjalnych Windowsa.


var FolderPath :string;

Registry := TRegistry.Create;
try
Registry.RootKey := HKey_Current_User;
Registry.OpenKey('Software\Microsoft\Windows\'+ 'CurrentVersion\Explorer\Shell Folders', False);
FolderName := Registry.ReadString('StartUp');
{takie te foldery są: Cache, Cookies, Desktop, Favorites, Fonts, Personal,
Programs, SendTo, Start Menu, StarUp}
finally Registry.Free;
end;

39. Usuwanie programowe pliku do kosza.


uses ShellAPI;

function DeleteFileWithUndo( sFileName : string ) : boolean;
var fos : TSHFileOpStruct;
begin
sFileName:= sFileName+#0; FillChar( fos, SizeOf( fos ), 0 );
with fos do begin
wFunc := FO_DELETE; pFrom := PChar( sFileName );
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := ( 0 = ShFileOperation( fos ) );
end;

40. Jak uzyskać listę stref czasowych?


uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var reg : TRegistry; ts : TStrings; i : integer;
begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false);
if reg.HasSubKeys then begin
ts := TStringList.Create; reg.GetKeyNames(ts); reg.CloseKey;
for i := 0 to ts.Count -1 do begin
reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false);
Memo1.Lines.Add(ts.Strings[i]); Memo1.Lines.Add(reg.ReadString('Display'));
Memo1.Lines.Add(reg.ReadString('Std')); Memo1.Lines.Add(reg.ReadString('Dlt'));
Memo1.Lines.Add('----------------------');
reg.CloseKey;
end; ts.Free; end else
reg.CloseKey; reg.free;
end;

41. Jak zwiększyć czas procesora przeznaczony na program?


Poniższy przykład zmienia priorytet aplikacji. Zmiana priorytetów powinna być stosowane z dużą ostrożnością - ponieważ przypisywanie zbyt wysokiego priorytetu może spowolnić pracę innych programów i systemów w ogóle. Zobacz help Win32 i jego funkcji SetThreadPriority().
przykład:

procedure TForm1.Button1Click(Sender: TObject);
var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

42. Zapisywanie całej zawartości schowka do pliku


var FS:TFileStream;
procedure TForm1.bClearClick(Sender: TObject);
begin
OpenClipBoard(0); EmptyClipboard; CloseClipBoard;
end;

procedure TForm1.BSaveClick(Sender: TObject);
var CBF:Cardinal; CBFList:TList; i:Integer; h:THandle;
p:Pointer; CBBlockLength,Temp:Cardinal; FS:TFileStream;
begin
if OpenClipBoard(0)then begin
CBFList:=TList.Create; CBF:=0;
repeat
CBF:=EnumClipboardFormats(CBF); if CBF< > 0 then
CBFList.Add(pointer(CBF)); until CBF=0; edit1.text:=IntToStr(CBFList.Count); if CBFList.Count > 0 then
begin
FS:=TFileStream.Create('e:\cp.dat',fmCreate); Temp:=CBFList.Count;
FS.Write(Temp,SizeOf(Integer)); for i:=0 to CBFList.Count-1 do begin
h:=GetClipboardData(Cardinal(CBFList[i]));
if h > 0 then begin
CBBlockLength:=GlobalSize(h);
if h *gt; 0 then begin
p:=GlobalLock(h);
if p < > nil then begin
Temp:=Cardinal(CBFList[i]); FS.Write(Temp,SizeOf(Cardinal));
FS.Write(CBBlockLength,SizeOf(Cardinal)); FS.Write(p^,CBBlockLength);
end;
GlobalUnlock(h); end; end; end; FS.Free; end;
CBFList.Free; CloseClipBoard; end;
end;

procedure TForm1.bLoadClick(Sender: TObject);
var h:THandle; p:Pointer; CBF:Cardinal; CBBlockLength:Cardinal;
i, CBCount:Integer; FS:TFileStream;
begin
if OpenClipBoard(0)then begin
FS:=TFileStream.Create('e:\cp.dat',fmOpenRead); if FS.Size=0 then Exit;
FS.Read(CBCount,sizeOf(Integer)); if CBCount=0 then Exit; for i:=1 to CBCount do
begin
FS.Read(CBF,SizeOf(Cardinal)); FS.Read(CBBlockLength,SizeOf(Cardinal));
h:=GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT,CBBlockLength);
if h > 0 then begin
p:=GlobalLock(h); if p=nil then GlobalFree(h)
else begin
FS.Read(p^,CBBlockLength); GlobalUnlock(h); SetClipboardData(CBF,h); end;
end; end;
FS.Free; CloseClipBoard; end; end; FormImage: TBitmap;
begin
FormImage := GetFormImage;
try Clipboard.Assign(FormImage); Image1.Picture.Assign(Clipboard);
finally FormImage.Free; end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Shape1.Shape := stEllipse; Shape1.Brush.Color := clLime; Image1.Stretch := True;
end;

W poniższym przykładzie zawartość ekranu jest kopiowana do schowka:
procedure CopyScreenToClipboard;
var dx,dy : integer; hSourcDC,hDestDC, hBM, hbmOld : THandle;
begin
dx := screen.width; dy := screen.height;
hSourcDC := CreateDC('DISPLAY',nil,nil,nil);
hDestDC := CreateCompatibleDC(hSourcDC);
hBM := CreateCompatibleBitmap(hSourcDC, dx, dy);
hbmold:= SelectObject(hDestDC, hBM);
BitBlt(hDestDC, 0, 0, dx, dy, hSourcDC, 0, 0, SRCCopy);
OpenClipBoard(form1.handle); EmptyClipBoard;
SetClipBoardData(CF_Bitmap, hBM); CloseClipBoard;
SelectObject(hDestDC,hbmold); DeleteObject(hbm);
DeleteDC(hDestDC); DeleteDC(hSourcDC);
end;

Programowa realizacja Wytnij, Kopiuj i Wklej.
procedure TForm1.Cut1Click(Sender: TObject);
begin
SendMessage (ActiveControl.Handle, WM_Cut, 0, 0);
end;

procedure TForm1.Copy1Click(Sender: TObject);
begin
SendMessage (ActiveControl.Handle, WM_Copy, 0, 0);
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
SendMessage (ActiveControl.Handle, WM_Paste, 0, 0);
end;

W przypadku wystąpienia MDI aplikacji, konieczne jest, aby wysłać wiadomość do aktywnego okna dziecka, tzn. zastosowanie: ActiveMDIChild.ActiveControl.Handle

Schowek (Clipboard) i TMemoryStream -- Należy najpierw zarejestrować ten format za pomocą RegisterClipboardFormat function():
CF_MYFORMAT: = RegisterClipboardFormat ("Mój opis Format");

Następnie wykonaj następujące czynności:
1. Tworzenie strumienia (stream) i zapisać danych.
2. Stworzyć globalny bufor pamięci i skopiować strumień (stream).
3. Przy pomocy Clipboard.SetAsHandle () wcisnąć globalny bufor do schowka.

przykład:
var hbuf : THandle; bufptr : Pointer; mstream : TMemoryStream;
begin
mstream := TMemoryStream.Create;
try {--zapis danych do mstreamu. --}
hbuf := GlobalAlloc(GMEM_MOVEABLE, mstream.size);
try bufptr := GlobalLock(hbuf);
try Move(mstream.Memory^, bufptr^, mstream.size);
Clipboard.SetAsHandle(CF_MYFORMAT, hbuf);
finally GlobalUnlock(hbuf); end;
except GlobalFree(hbuf); raise; end;
finally mstream.Free; end;
end;

WAŻNE: Nie usuwaj bufora po GlobalAlloc(). Jak tylko włożysz go do schowka, to będzie można go używać.

Aby pobrać dane ze strumienia, można użyć następującego kodu:
var hbuf : THandle; bufptr : Pointer; mstream : TMemoryStream;
begin
hbuf := Clipboard.GetAsHandle(CF_MYFORMAT);
if hbuf < > 0 then begin bufptr := GlobalLock(hbuf);
if bufptr < > nil then begin
try mstream := TMemoryStream.Create;
try mstream.WriteBuffer(bufptr^, GlobalSize(hbuf)); mstream.Position := 0;
{-- odczyt danych z mstreamu. --}
finally mstream.Free; end;
finally GlobalUnlock(hbuf); end; end; end;
end;

43. Symulacja naciśniecia myszy - programowa


procedure tform1.timer1timer(sender: tobject);
var x,y:integer;
begin
x:=random(300); y:=random(200);
sendmessage(handle,wm_lbuttondown,mk_lbutton,x+y shl 16);
sendmessage(handle,wm_lbuttonup,mk_lbutton,x+y shl 16);
end;

procedure tform1.formmousedown(sender: tobject; button: tmousebutton;
shift: tshiftstate; x, y: integer);
begin
label1.caption:=inttostr(x)+','+inttostr(y); label1.left:=x; label1.top:=y;
end;

Symulacja wciskania klawiszy myszy.
Na formie umiescić komponent TTimer i dla jego zdarzenia (Ewent) wstawić:

procedure tform1.timer1timer(sender: tobject);
var x, y: integer;
begin
x := random(screen.width); y := random(screen.height);
sendmessage(handle, wm_lbuttondown, mk_lbutton, x + y shl 16);
sendmessage(handle, wm_lbuttonup, mk_lbutton, x + y shl 16);
end;

W celu upewnienia się, że wiadomości zostaną wysłane w zdarzeniu Onmousedown wstawmy kreślenie elipsy - rzekomo w tym miejscu nastąpi klik myszą.

procedure tform1.formmousedown(sender: tobject; button: tmousebutton;
shift: tshiftstate; x, y: integer);
begin
form1.canvas.ellipse(x - 2, y - 2, x + 2, y + 2);
end;

44.   Dzielenie i łączenie plików


Przykład dzieli plik na fragmenty określonego rozmiaru (SizeOfFiles) i zapisuje jako FileName.001, FileName.002, FileName.003 a pasek postępu (TProgressBar) pokazuje stan tej operacji.

//dzielenie pliku:
function SplitFile(FileName : TFileName; SizeofFiles : Integer; ProgressBar : TProgressBar) : Boolean;
var i : Word; fs, sStream: TFileStream; SplitFileName: String;
begin
ProgressBar.Position := 0; fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
for i := 1 to Trunc(fs.Size / SizeofFiles) + 1 do begin
SplitFileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
sStream := TFileStream.Create(SplitFileName, fmCreate or fmShareExclusive);
try
if fs.Size - fs.Position < SizeofFiles then
SizeofFiles := fs.Size - fs.Position; sStream.CopyFrom(fs, SizeofFiles);
ProgressBar.Position := Round((fs.Position / fs.Size) * 100);
finally sStream.Free;
end; end; finally fs.Free; end;
end;

// łączenie plików w 1 duży plik(CombinedFileName) - wskazujemy nazwę pierwszego z indeksem 001 (FileName):
function CombineFiles(FileName, CombinedFileName : TFileName) : Boolean;
var i: integer; fs, sStream: TFileStream; filenameOrg: String;
begin
i := 1;   fs := TFileStream.Create(CombinedFileName, fmCreate or fmShareExclusive);
try
  while FileExists(FileName) do begin
sStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
  fs.CopyFrom(sStream, 0);   finally   sStream.Free; end; Inc(i);
FileName := ChangeFileExt(FileName, '.'+ FormatFloat('000', i));
end;   finally   fs.Free;
end;   end;

// przykład:
procedure TForm1.Button1Click(Sender: TObject);
begin
SplitFile('C:\temp\FileToSplit.chm',1000000, ProgressBar1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
CombineFiles('C:\temp\FileToSplit.001','H:\temp\FileToSplit.chm');
end;

45. Usuwanie katalogu wraz z jego zawartością.


function deletedir(dir : string) : boolean;
var found : integer;   searchrec : tsearchrec;
begin
result:=false;
if ioresult < > 0 then chdir(dir);
if ioresult < > 0 then
begin
showmessage('Nie mogę wejść do katalogu: '+dir);   exit;
end;
found := findfirst('*.*', faanyfile, searchrec);
while found = 0 do
begin
if (searchrec.name < > '.') and (searchrec.name < > '..') then
if (searchrec.attr and fadirectory) < > 0 then
begin
if not deletedir(searchrec.name) then exit;
end else
if not deletefile(searchrec.name) then
begin
showmessage('Nie mogę usunąć pliku: '+searchrec.name);   exit;
end;
found := findnext(searchrec);
end;
findclose(searchrec);   chdir('..');   rmdir(dir);   result:=ioresult=0;
end;

{ usuwanie katalogu z jego zawartością }
function deletedir(dir : string) : boolean;
var found : integer;   searchrec : tsearchrec;
begin
result:=false;
if ioresult < > 0 then chdir(dir);
if ioresult < > 0 then
begin
showmessage('Nie mogę wejść do katalogu: '+dir);   exit;
end;
found := findfirst('*.*', faanyfile, searchrec);
while found = 0 do
begin
if (searchrec.name < > '.') and (searchrec.name < > '..') then
if (searchrec.attr and fadirectory) < > 0 then
begin
if not deletedir(searchrec.name) then exit;
end else
if not deletefile(searchrec.name) then
begin
showmessage('Nie mogę usunąć katalogu: '+searchrec.name);   exit;
end;
found := findnext(searchrec);   end;   findclose(searchrec);   chdir('..');
rmdir(dir);   result:=ioresult=0;
end;

46. Obliczenie liczby plików w katalogu.


uses   windows, { ... }

function filecount(const afolder: string): integer;
var   h: thandle;   data: twin32finddata;
begin
result := 0;
h := findfirstfile(pchar(afolder + '*.*'), data);
if h < > invalid_handle_value then
repeat
inc(result, ord(data.dwfileattributes and file_attribute_directory = 0));
until
not findnextfile(h, data);   windows.findclose(h);
end;

47. Skuteczne usuwanie pliku.


Usuwany normalnie plik ktoś inny może go odtworzyć. W tej procedurze plik jest przed zniszczeniem nadpisywany losową kombinacją znaków - odtworzyć można taką sieczkę.

procedure wipefile(filename: string);
var   buffer: array [0..4095] of byte;   max, n: longint;   i: integer;   fs: tfilestream;

procedure randomizebuffer;
var   i: integer;
begin
for i := low(buffer) to high(buffer) do   buffer[i] := random(256);   end;
begin
fs := tfilestream.create(filename, fmopenreadwrite or fmshareexclusive);
try
for i := 1 to 3 do begin
randomizebuffer;   max := fs.size;   fs.position := 0;
while max > 0 do begin
if max > sizeof(buffer) then   n := sizeof(buffer)
else
n := max;   fs.write(buffer, n);   max := max - n;
end;
flushfilebuffers(fs.handle);   end;
finally   fs.free;   end;   deletefile(filename);
end;

48. Wyszukiwanie plików w katalogach według zadanej maski.


parametr startfolder wskazuje wstępny katalog poszukiwań;
parametr mask określa maskę wyszukiwania (np. '*. pas "),
parametr list określa listę, w których będą rejestrowane wyniki wyszukiwania;
opcjonalny parametr scansubfolders wskazuje na obowiązkową potrzebę szukania w podkatalogach.

procedure findfiles(startfolder, mask: string; list: tstrings; scansubfolders: boolean = true);
var   searchrec: tsearchrec;   findresult: integer;
begin
list.beginupdate;
try
startfolder:=includetrailingbackslash(startfolder);
findresult:=findfirst(startfolder+'*.*', faanyfile, searchrec);
try
while findresult = 0 do with searchrec do begin
if (attr and fadirectory) < > 0 then begin
if scansubfolders and (name < > '.') and (name < > '..') then
findfiles(startfolder+name, mask, list, scansubfolders);
end else begin
if matchesmask(name, mask) then list.add(startfolder+name);
end;
findresult:=findnext(searchrec);
end;
finally   findclose(searchrec);   end;
finally   list.endupdate;   end;
end;

Przykład wykorzystania:
procedure tform1.button1click(sender: tobject);
begin
findfiles('c:program files', '*.exe', memo1.lines, true);
end;

49.   Sortowanie w TStringGrid według kolumn


type   TMoveSG = class(TCustomGrid); // reveals protected MoveRow procedure {...}

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
{ Sort rows based on the contents of two or more columns.
Sorts first by column 1. If there are duplicate values in column 1, the next sort column is column 2 and so on...}
SortGridByCols(StringGrid1, [1, 2, 0, 3, 4]);
end;

50. Zmiana koloru wybranej celi w TStringGridzie


W selektorze właściwości wybrać (klik) opcję OnDrawCell, która po uzupełnieniu powinna mieć taką postać:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
const SelectedColor = Clblue;
begin
if (state = [gdSelected]) then     with TStringGrid(Sender), Canvas do begin
Brush.Color := SelectedColor;     FillRect(Rect);
TextRect(Rect, Rect.Left + 2, Rect.Top + 2, Cells[aCol, aRow]);
end; end;

51. Autodopasowanie rozmiaru kolumn do tekstu


procedura tak dopasowuje szerokość kolumn aby tekst (i tylko tekst) w nich był widoczy w całości. W przykładzie ograniczono ilość rekordów do 10

type TGridHack = class(TCustomGrid);

procedure ResizeStringGrid(_Grid: TCustomGrid);
var Col, Row: integer; Grid: TGridHack; MaxWidth: integer; ColWidth: integer;
ColText: string; MaxRow: integer; ColWidths: array of integer;
begin
Grid := TGridHack(_Grid);     SetLength(ColWidths, Grid.ColCount);     MaxRow := 10;
if MaxRow > Grid.RowCount then     MaxRow := Grid.RowCount;
for Col := 0 to Grid.ColCount - 1 do begin
MaxWidth := 0;     for Row := 0 to MaxRow - 1 do begin
ColText := Grid.GetEditText(Col, Row);     ColWidth := Grid.Canvas.TextWidth(ColText);
if ColWidth > MaxWidth then     MaxWidth := ColWidth;
end;
if goVertLine in Grid.Options then     Inc(MaxWidth, Grid.GridLineWidth);
ColWidths[Col] := MaxWidth + 4;     Grid.ColWidths[Col] := ColWidths[Col];
end;     end;

52.   Zmiana koloru tła w TRichEdit pod wybranym znakiem.


uses RichEdit;

procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);
var Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do begin
cbSize := SizeOf(Format);   dwMask := CFM_BACKCOLOR;   crBackColor := AColor;
Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end; end;

//przykład pod znakiem jest tło zółte....
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetSelBgColor(RichEdit1, clYellow);
end;

53.   Rozwijanie i zwijanie drzewa w TTreeView


function IsTreeviewFullyExpanded(tv: TTreeview): Boolean; //rozwijanie
var Node: TTreeNode;
begin
Assert(Assigned(tv));   if tv.Items.Count > 0 then begin
Node := tv.Items[0];   Result := True;
while Result and Assigned(Node) do begin
Result := Node.Expanded or not Node.HasChildren;   Node := Node.GetNext;
end; end   else   Result := False
end;

function IsTreeviewFullyCollapsed(tv: TTreeview): Boolean; //zwijanie
var Node: TTreeNode;
begin
Assert(Assigned(tv));   if tv.Items.Count > 0 then begin
Node := tv.Items[0];   Result := True;
while Result and Assigned(Node) do begin
Result := not (Node.Expanded and Node.HasChildren);   Node := Node.GetNext;
end; end   else   Result := False
end;

54.   Panel o zaokrąglonych rogach z TShape.


procedure TForm1.FormCreate(Sender: TObject);
const bgcolor = $00FFDDEE; linecolor = $00554366;
var img: array of TImage; reg: hrgn; i: Integer;
begin
for i := 0 to ComponentCount - 1 do begin
if Components[i].ClassName = 'TPanel' then begin
setlength(img, Length(img) + 1);
img[i] := TImage.Create(Self);
img[i].Width := (Components[i] as TPanel).Width;
img[i].Height := (Components[i] as TPanel).Height;
img[i].Parent := (Components[i] as TPanel);
img[i].Canvas.Brush.Color := bgcolor;
img[i].Canvas.pen.Color := bgcolor;
img[i].Canvas.Rectangle(0,0,img[i].Width, img[i].Height);
img[i].Canvas.pen.Color := linecolor;
img[i].Canvas.RoundRect(0,0,img[i].Width - 1,img[i].Height - 1,20,20);
reg := CreateRoundRectRgn(0,0,(Components[i] as TPanel).Width,
(Components[i] as TPanel).Height, 20,20);
setwindowrgn((Components[i] as TPanel).Handle, reg, True);
deleteobject(reg);
end; end;
end;

55.   Wyróżnienie tłustym drukiem wybranych dni w TMonthCalendar (autor Thomas Stutz).


procedure TForm1.MonthCalendar1GetMonthInfo(Sender: TObject;
Month: Cardinal; var MonthBoldInfo: Cardinal);
begin
if Month = 4 then { w kwietniu grubym drukiem pokaż dni: 3,21,28}
MonthCalendar1.BoldDays([3,21,28],MonthBoldInfo);
end;

56.   Tworzenie kolorowych wierszy w TListView (autor: S.Grossenbacher).


procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
with ListView1.Canvas.Brush do begin
case Item.Index of
0: Color := clYellow;  //pierwszy wiersz żółty
1: Color := clGreen;  // drugi zielony
2: Color := clRed;   //3ci czerwony
end;   end;
end;

57.  Konwersja kodu ANSI na UTF


Za pomocą dodatkowej funkcji można dokonac konwersji tekstu z UTF8 na ANSI i z ANSI na UTF8

function Utf8ToAnsi(x: string): ansistring;
{ Function that recieves UTF8 string and converts to ansi string }
var i: integer;   b1, b2: byte;
begin
Result := x; i := 1; while i <= Length(Result) do begin
if (ord(Result[i]) and $80) < > 0 then begin
b1 := ord(Result[i]);   b2 := ord(Result[i + 1]);
if (b1 and $F0) < > $C0 then   Result[i] := #128
else begin
Result[i] := Chr((b1 shl 6) or (b2 and $3F));
Delete(Result, i + 1, 1);
end; end;   inc(i);
end; end;

function AnsiToUtf8(x: ansistring): string;
{ Function that recieves ansi string and converts to UTF8 string }
var i: integer;   b1, b2: byte;
begin
Result := x;
for i := Length(Result) downto 1 do
if Result[i] >= #127 then begin
b1 := $C0 or (ord(Result[i]) shr 6);   b2 := $80 or (ord(Result[i]) and $3F);
Result[i] := chr(b1);   Insert(chr(b2), Result, i + 1);
end; end;

58.   Zamiana liczb dziesiętnych na dwójkowe i odwrotnie


function IntToBin(Value: LongInt;Size: Integer): String;
var i: Integer;
begin
Result:='';   for i:=Size downto 0 do begin
if Value and (1 shl i) < > 0 then   Result:=Result+'1';
else   Result:=Result+'0';
end; end;

function BinToInt(Value: String): LongInt;
var i,Size: Integer;
begin
Result:=0;   Size:=Length(Value);
for i:=Size downto 0 do begin
if Copy(Value,i,1)='1' then   Result:=Result+(1 shl i);
end; end;

59.   Ile jest słów w łańcuchu (stringu)?


Policzy to poniższa funkcja:

Function Seps(As_Arg: Char): Boolean;
Begin
Seps := As_Arg In [#0..#$1F, ' ', '.', ',', '?', ':', ';', '(',')', '/', '\'];
End;

Function Word_Count(CText: String): Longint;
Var Ix: Word;   Work_Count: Longint;
Begin
Work_Count := 0;   Ix := 1;
While Ix <= Length(Wc_Arg) Do Begin
While (Ix < = Length(Wc_Arg)) And Seps(Wc_Arg[Ix]) Do   Inc(Ix);
If Ix < = Length(Wc_Arg) Then Begin
Inc(Work_Count);   While (Ix < = Length(WC_Arg)) And (Not Seps(WC_Arg[Ix])) Do   Inc(Ix);
End;   End;   Word_Count := Work_Count;
End;

60.   Nieudokumentowana w Delphi zamiana   BinToHex   i   HexToBin


procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;

procedure TForm1.Button1Click(Sender: TObject);
var E: Extended;   //Make sure there is room for null terminator
Buf: array[0..SizeOf(Extended) * 2] of Char;
begin
E := Pi;   Label1.Caption := Format('E starts off as %.15f', [E]);
BinToHex(@E, Buf, SizeOf(E));
//Slot in the null terminator for the PChar, so we can display it easily
Buf[SizeOf(Buf) - 1] := #0;
Label2.Caption := Format('As text, the binary contents of E look like %s', [Buf]);
//Translate just the characters, not the null terminator
HexToBin(Buf, @E, SizeOf(Buf) - 1);
Label3.Caption := Format('Back from text to binary, E is now %.15f', [E]);
end;

61. Eksport obrazu TImage do pliku w formacie WMF


procedure ExportaBMPtoWMF(Imagem:TImage;Dest:Pchar);
var Metafile : TMetafile; MetafileCanvas : TMetafileCanvas; DC : HDC; ScreenLogPixels : Integer;
begin
Metafile := TMetafile.Create;
try
DC := GetDC(0);   ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
Metafile.Inch := ScreenLogPixels;
Metafile.Width := Imagem.Picture.Bitmap.Width;
Metafile.Height := Imagem.Picture.Bitmap.Height;
MetafileCanvas := TMetafileCanvas.Create(Metafile, DC);
ReleaseDC(0, DC);
try
MetafileCanvas.Draw(0, 0, Imagem.Picture.Bitmap);
finally   MetafileCanvas.Free;
end;
Metafile.Enhanced := FALSE;   Metafile.SaveToFile(Dest);
finally   Metafile.Destroy;   end;
end;

62.  Tworzenie okienka o regulowanych rozmiarach.


unit Unit1;

interface

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

type TForm1 = class(TForm) PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
public
end;

var Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_CAPTION or WS_SIZEBOX or WS_SYSMENU;
Params.ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
end;

procedure TForm1.CreateWnd;
begin
inherited CreateWnd;   SendMessage(Self.Handle, WM_SETICON, 1, 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
PaintBox1.Align := alRight;   PaintBox1.Width := 16;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
With PaintBox1 do
DrawFrameControl(Canvas.Handle, Rect(Width - 15, Height - 15, Width, Height), DFC_SCROLL, DFCS_SCROLLSIZEGRIP );
end;

end.

63. Okno dialogowe wyboru katalogów - wersja 2.


W module filectrl są dwie metody wyboru katalogu - oto jedna z nich:

uses shlobj

function browsefolderdialog(title: pchar): string;
var   titlename: string;   lpitemid: pitemidlist;   browseinfo: tbrowseinfo;
displayname: array[0..max_path] of char; temppath: array[0..max_path] of char;
begin
fillchar(browseinfo, sizeof(tbrowseinfo), #0);
browseinfo.hwndowner := getdesktopwindow;   browseinfo.pszdisplayname := @displayname;
titlename := title;   browseinfo.lpsztitle := pchar(titlename);
browseinfo.ulflags := bif_returnonlyfsdirs;   lpitemid := shbrowseforfolder(browseinfo);
if lpitemid < > nil then
begin
shgetpathfromidlist(lpitemid, temppath);   result := temppath;   globalfreeptr(lpitemid);
end;   end;

64. Wykorzystanie okna MessageDlg do centrowania formy.


procedure TForm1.Button1Click(Sender: TObject);
var MyForm: TForm;
begin
MyForm:=CreateMessageDialog('To jest przykład', mtInformation, [mbOk]);
with MyForm do
begin
Height:=130;   Width:=150;
Left:=Trunc((Form1.Width-Width)/2)+Form1.Left;
Top:=Trunc((Form1.Height-Height)/2)+Form1.Top;
ShowModal;
end;   end;

65. Zmiana czcionki Hinta - dymka podpowiedzi.


//przykład:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private {Private declarations}
public {Public declarations}
procedure MyShowHint(var HintStr: string; var CanShow: Boolean;var HintInfo: THintInfo);
end;

var Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
var i : integer;
begin
for i := 0 to Application.ComponentCount - 1 do
if Application.Components[i] is THintWindow then
with THintWindow(Application.Components[i]).Canvas do
begin
Font.Name:= 'Arial';   Font.Size:= 18;   Font.Style:= [fsBold]; HintInfo.HintColor:= clWhite;
end; end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint := MyShowHint;
end;

66.   Tworzenie ikony z bitmapy (bmp na ico)


Należy stworzyć 2 bitmapy - bitmapę maskę (AndMask) i bitmapę obrazu ikony (XOrMask)oraz wykorzystać funkcję API Windowsa - CreateIconIndirect(), np:

procedure TForm1.Button1Click(Sender: TObject);
var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap;
XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon;
begin     {Get the icon size}
IconSizeX := GetSystemMetrics(SM_CXICON);
IconSizeY := GetSystemMetrics(SM_CYICON);

{Create the "And" mask}
AndMask := TBitmap.Create;   AndMask.Monochrome := true;
AndMask.Width := IconSizeX;   AndMask.Height := IconSizeY;

{Draw on the "And" mask}
AndMask.Canvas.Brush.Color := clWhite;   AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
AndMask.Canvas.Brush.Color := clBlack;   AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);

{Create the "XOr" mask}
XOrMask := TBitmap.Create;   XOrMask.Width := IconSizeX;   XOrMask.Height := IconSizeY;

{Draw on the "XOr" mask}
XOrMask.Canvas.Brush.Color := ClBlack;
XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));
XOrMask.Canvas.Pen.Color := clRed;   XOrMask.Canvas.Brush.Color := clRed;
XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);

{Create a icon}
Icon := TIcon.Create;   IconInfo.fIcon := true;   IconInfo.xHotspot := 0;
IconInfo.yHotspot := 0;   IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;   Icon.Handle := CreateIconIndirect(IconInfo);

{Destroy the temporary bitmaps}
AndMask.Free;   XOrMask.Free;

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

{Assign the application icon}
Application.Icon := Icon;

{Force a repaint}
InvalidateRect(Application.Handle, nil, true);

{Free the icon}
Icon.Free;
end;

Poniżej konwersja obrazu do ikony 32x32 pikseli:

unit main;

interface

uses windows, messages, sysutils, classes, graphics, controls, forms, dialogs, extctrls, stdctrls;

type
tform1 = class (tform)
button1: tbutton;
image1: timage;
image2: timage;
procedure button1click(sender: tobject);
procedure formcreate(sender: tobject);
private { private declarations }
public { public declarations }
end ;

var form1: tform1;

implementation
{$r *.dfm}

procedure tform1.button1click(sender: tobject);
var   windc, srcdc, destdc: hdc;   oldbitmap: hbitmap;   iinfo: ticoninfo;
begin
geticoninfo(image1.picture.icon.handle, iinfo);   windc := getdc(handle);
srcdc := createcompatibledc(windc);   destdc := createcompatibledc(windc);
oldbitmap := selectobject(destdc, iinfo.hbmcolor);   oldbitmap := selectobject(srcdc, iinfo.hbmmask);
bitblt(destdc, 0 , 0 , image1.picture.icon.width, image1.picture.icon.height, srcdc, 0 , 0 , srcpaint);
image2.picture.bitmap.handle := selectobject(destdc, oldbitmap);
deletedc(destdc);   deletedc(srcdc);   deletedc(windc);
image2.picture.bitmap.savetofile(extractfilepath(application.exename) + 'myfile.bmp' );
end;

procedure tform1.formcreate(sender: tobject);
begin
image1.picture.icon.loadfromfile( 'c:\myicon.ico' );
end;

end.

67.   Zapis komponentu z kategorii TWinControl jako obrazu do pliku


Poniższa procedura zrzuca ten komponent do Bitmapy i po konwersji do JPG zapisuje go do pliku

uses Jpeg;
procedure Zrzucaj (AControl : TWinControl; AFileName : string; UseJpegFormat : boolean = true);
var Canvas : TCanvas;   Bmp : TBitmap;   Jpg : TJpegImage;
begin
try     Canvas := TCanvas.Create;
Canvas.Handle := GetDc(AControl.Handle);
Bmp := TBitmap.Create;
Bmp.Width := AControl.Width;   Bmp.Height := AControl.Height;
bmp.PixelFormat :=pf24bit;
Bmp.Canvas.CopyRect(Canvas.ClipRect, Canvas, Canvas.ClipRect);
if UseJpegFormat then begin
Jpg := TJpegImage.Create;   jpg.PixelFormat := jf24bit;   Jpg.Assign(Bmp);
Jpg.SaveToFile(ChangeFileExt(AFileName,'.jpg'));
end   Else   Bmp.SaveToFile(ChangeFileExt(AFileName,'.bmp'));
finally   ReleaseDC(AControl.Handle, Canvas.Handle);   FreeAndNil(Bmp);
if UseJpegFormat then FreeAndNil(Jpg);   FreeAndNil(Canvas);
end;   end;

68. Konwersja bmp na rtf. - tak też można . Oto przykład:


function bitmaptortf(pict: tbitmap): string ;
var   bi, bb, rtf: string ;   bis, bbs: cardinal;   achar: shortstring;   hexpict: string ; i: integer;
begin
getdibsizes(pict.handle, bis, bbs); setlength(bi, bis); setlength(bb, bbs);
getdib(pict.handle, pict.palette, pchar(bi)^, pchar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap0 ' ;
setlength(hexpict, (length(bb) + length(bi)) * 2 );
i := 2 ;
for bis := 1 to length(bi) do begin
achar := inttohex(integer(bi[bis]), 2 );
hexpict[i - 1] := achar[ 1 ]; hexpict[i] := achar[ 2 ];   inc(i, 2 );
end ;
for bbs := 1 to length(bb) do
begin
achar := inttohex(integer(bb[bbs]), 2 );   hexpict[i - 1] := achar[ 1 ];
hexpict[i] := achar[ 2 ];   inc(i, 2);
end ;
rtf := rtf + hexpict + ' }}'; result := rtf;
end;

69.   Zakończenie wszystkich dotychczas otwartych aplikacji


z tą procedurą ostrożnie - upewnij się czy nowe dane w tych aplikacjach już zapisane - bo inaczej to przepadną!

procedure TForm1.ButtonKillAllClick(Sender: TObject);
var pTask : PTaskEntry; Task : Bool; ThisTask: THANDLE;
begin
GetMem (pTask, SizeOf (TTaskEntry));   pTask^.dwSize := SizeOf (TTaskEntry);
Task := TaskFirst (pTask);
while Task do begin
if pTask^.hInst = hInstance then   ThisTask := pTask^.hTask
else   TerminateApp (pTask^.hTask, NO_UAE_BOX);   Task := TaskNext (pTask);
end;   TerminateApp (ThisTask, NO_UAE_BOX);
end;

70.   Pliki tymczasowe w Windows


dostęp do nich (ich katalogu) poprzez funkcję API - GetTempPath . W przykładzie po kliku na Button1 te pliki są wyszczególnone w polu Memo1.

procedure TForm1.Button1Click(Sender: TObject);

function CreateTmpFileName(Prefijo: String): String;
var   Path : array[0..MAX_PATH] of Char;   Fichero : array[0..MAX_PATH] of Char;
begin
FillChar(Path,SizeOf(Path),#0);   FillChar(Fichero,SizeOf(Fichero),#0);
GetTempPath(MAX_PATH, Path);   GetTempFilename(Path, PChar(Prefijo), 0, Fichero);
Result := Fichero;
end;
begin
Memo1.Lines.Append( CreateTmpFileName('TmpF') );
end;

71.   Zamknięcie metodą programową innej aplikacji.


wysłanie do systemu zdarzenia WM_QUIT:

PostMessage(FindWindow(Nil, 'window caption'), WM_QUIT, 0, 0);
//gdzie 'window caption' jest nagłówkiem okna wysyłającego wiadomość

72.   Zatrzymanie programu bez użycia Timera.


w przykładzie użyto pętli, która sprawdza czas i wysyła wiadomości (ProcessMessage) pozwalając Windowsowi na wykonywanie petli.

procedure Delay(ms : longint);
var TheTime : LongInt;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Start Test');
Delay(2000);
ShowMessage('End Test');
end;

73.   Wysłanie poczty E-mail z tematem i tekstem.


uses ShellAPI;

{ ...code...}

procedure SendMail(Address, Subject, Text: string);
var H: HWND;
begin
H:=Application.Handle;
ShellExecute(H,'open',PChar('mailto:'+Address+'?subject='+Subject+
'&body_='+Text),nil,nil,SW_SHOW);
end;

{ a tak używać }
procedure TMainForm.EmailButtonClick(Sender: TObject);
begin
SendMail('awalum@interia.pl','Fajna informacja','Serwus Johny!');
end;

74. Jak uruchomić mój program z każdym startem systemu Windows?


uses Registry, {For Win32} IniFiles; {For Win16}
{$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF}

{For Win32}
procedure TForm1.Button1Click(Sender: TObject);
var reg: TRegistry;
begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', false);
reg.WriteString('My App', Application.ExeName); reg.CloseKey; reg.free;
end;

{For Win16}
procedure TForm1.Button2Click(Sender: TObject);
var WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; s : string;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('windows', 'run', '');
if s = '' then s := Application.ExeName else s := s + ';' + Application.ExeName;
WinIni.WriteString('windows', 'run', s);
WinIni.Free;
end;

75. Jak zdobyć nazwy wolnych portów COM?


// Pokaże nazwy dostępnych portów comm (COM1, COM2, ...)
// Użyty klucz rejestru: HKEY_LOCAL_MACHINE \ hardware \ DeviceMap \ serialcomm

uses registry;
...
procedure TForm1.Button1Click(Sender: TObject);
var reg : TRegistry; st : TStrings; i : integer;
begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('hardware\devicemap\serialcomm',false);
st := TStringList.Create; reg.GetValueNames(st);
for i := 0 to st.Count -1 do begin
Memo1.Lines.Add(reg.ReadString(st.Strings[i])); end;
st.Free; reg.CloseKey; reg.free;
end;

76.Odczyt folderów specjalnych Windowsa.


var FolderPath :string;

Registry := TRegistry.Create;
try
Registry.RootKey := HKey_Current_User;
Registry.OpenKey('Software\Microsoft\Windows\'+ 'CurrentVersion\Explorer\Shell Folders', False);
FolderName := Registry.ReadString('StartUp');
{takimi folderami mogą byC: Cache, Cookies, Desktop, Favorites, Fonts, Personal, Programs, SendTo, Start Menu, StarUp}
finally Registry.Free;
end;