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;
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;
// 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;
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;
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;
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;
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;
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;
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.
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.
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;
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;
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;
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;
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.
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;
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;
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);
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
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
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.
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
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;
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;
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").
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;
procedure tform1.button1click(sender: tobject);
begin
shellexecute(handle, nil, 'c:windowsstart menudelphidelphi6.lnk',
nil, nil, sw_shownormal);
end;
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;
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;
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.
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;
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;
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;
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;
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.
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;
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.
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.
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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.
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;
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;
//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;
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.
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;
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;
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;
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;
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ść
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;
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;
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;
// 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;
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;