Funkcje obsługi systemu

1.   Odświeżenie okna komputera

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0);
end;

2.   Określenie katalagu z systemem Windows

Z wykorzystaniem funkcji API - GetWindowsDirectory. //przykład:
{$IFNDEF WIN32}   const MAX_PATH = 144;   {$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var a : Array[0..MAX_PATH] of char;
begin
GetWindowsDirectory(a, sizeof(a));   ShowMessage(StrPas(a));
GetSystemDirectory(a, sizeof(a));   ShowMessage(StrPas(a));
end;

3.   Pokaż / ustaw czas podwójnego kliku

//przykład ustawienia...
procedure TForm1.Button1Click(Sender: TObject);
begin   // will reset after system start
SetDoubleClickTime(1500);
end;

// przykład pokazania...
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetDoubleClickTime));
end;

4.   Sprawdzenie czy czas jest ustawiony na format 24 - godzinny

function Is24HourTimeFormat: Boolean;
var DefaultLCID: LCID;
begin
DefaultLCID := GetThreadLocale;
Result := 0 < > StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME,'0'), 0);
end;

5.   Pokaz /ustawienie schowka dla tekstu (bez użycia VCL)

unit Unit1;

interface

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

type TForm1 = class(TForm)
Button1: TButton;   Button2: TButton;
function GetClipBoardText: string;
procedure SetClipBoardText(const Value: string);
procedure Open;
procedure SetBuffer(Format: Word; var Buffer; Size: Integer);
procedure Adding;
procedure Clear;
constructor CreateRes(Ident: Integer);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
FOpenRefCount: Integer;
FClipboardWindow: HWND;
FAllocated: Boolean;
FEmptied: Boolean;
FMessage: string;
public { Public declarations }
end;

var Form1: TForm1;

resourcestring SCannotOpenClipboard = 'Nie mogę otworzyć schowka';

implementation   {$R *.dfm}

//Create resource for resourceString
constructor TForm1.CreateRes(Ident: Integer);
begin
FMessage := LoadStr(Ident);
end;

//Status: Adding
procedure TForm1.Adding;
begin
if (FOpenRefCount < > 0) and not FEmptied then begin
Clear;   FEmptied := True;
end;   end;

//Empty clipboard
procedure TForm1.Clear;
begin
Open;   try   EmptyClipboard; finally   Close; end;
end;

//Set buffer
procedure TForm1.SetBuffer(Format: Word; var Buffer; Size: Integer);
var Data: THandle; DataPtr: Pointer;
begin
Open;   try   Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, Size);
try   DataPtr := GlobalLock(Data);
try   Move(Buffer, DataPtr^, Size);   Adding;   SetClipboardData(Format, Data);
finally   GlobalUnlock(Data);   end;
except   GlobalFree(Data);   raise;   end;
finally   Close;
end;   end;

//Open the clipboard
procedure TForm1.Open;
begin
if FOpenRefCount = 0 then begin
FClipboardWindow := Application.Handle;
if FClipboardWindow = 0 then begin   {$IFDEF MSWINDOWS}
FClipboardWindow := Classes.AllocateHWnd(MainWndProc);   {$ENDIF} {$IFDEF LINUX}
FClipboardWindow := WinUtils.AllocateHWnd(MainWndProc);   {$ENDIF}
FAllocated := True;   end;
if not OpenClipboard(FClipboardWindow) then
raise Exception.CreateRes(@SCannotOpenClipboard);   FEmptied := False; end; Inc(FOpenRefCount);
end;

//Get the clipboard text
function TForm1.GetClipBoardText: string;
var Data: THandle;
begin
Open;   Data := GetClipboardData(CF_TEXT);
try   if Data < > 0 then   Result := PChar(GlobalLock(Data))
else   Result := '';
finally  if Data < > 0 then GlobalUnlock(Data);   Close;
end;   end;

procedure TForm1.SetClipBoardText(const Value: string);
begin   //Set ClipboardText
SetBuffer(CF_TEXT, PChar(Value)^, Length(Value) + 1);
end;

//Get the clipboard text
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetClipboardText);
end;

//Set the clipboard text
procedure TForm1.Button2Click(Sender: TObject);
begin
SetClipboardText('- > Big-X < -');
end;

end.

6.   Dodanie w programie pozycji do Menu systemowego Windowsa

private
procedure OnMessageHandler(var Msg: TMsg; var Handled: Boolean);
public { Public declarations }
end;

var Form1: TForm1;

implementation   {$R *.dfm}

// Identifiers of the new menu items
const SC_MyMenuItem1 = WM_USER + $101;   SC_MyMenuItem2 = WM_USER + $102;

procedure TForm1.FormCreate(Sender: TObject);
var hSysMenu: THandle;
begin // Get Systemmenu Handle
hSysMenu := GetSystemMenu(Application.Handle, False);   // Add own menu items
AppendMenu(hSysMenu, MF_SEPARATOR, 0, #0);
AppendMenu(hSysMenu, MF_STRING, SC_MyMenuItem1, ' &My Menuitem 1');
AppendMenu(hSysMenu, MF_STRING or MF_CHECKED , SC_MyMenuItem2, ' &My Menuitem 2');
Application.OnMessage := OnMessageHandler;   // Assign a own OnMessage event handler
end;

// OnMessage event handler
procedure TForm1.OnMessageHandler;
begin
if Msg.message = WM_SYSCOMMAND then begin
case Msg.wParam of   // Which item selected?
SC_MyMenuItem1:   begin   ShowMessage('SC_MyMenuItem1');   Handled := True;   end;
SC_MyMenuItem2:   begin   ShowMessage('SC_MyMenuItem2');   Handled := True;   end;
end;   end;   end;

7.   Kopiowanie formy i ekranu do schowka

// Kopiowanie formy do schowka
procedure TForm1.Button1Click(Sender: TObject);
var FormImage: TBitmap;
begin
FormImage := GetFormImage;
try Clipboard.Assign(FormImage);   Image1.Picture.Assign(Clipboard);
finally   FormImage.Free;   end;
end;

// kopiowanie całego ekranu 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;

8.   Przykład użycia rejestru Windowsa

uses Registry, Windows;

procedure TForm1.Button1Click(Sender: TObject);
var Registry: TRegistry;
begin
Registry := TRegistry.Create;   { tworzy objekt TRegistry }
Registry.RootKey := hkey_local_machine;   { ustawia rootkey; np.. hkey_local_machine or hkey_current_user }
Registry.OpenKey('software\MyRegistryExample',true);   { otwiera i tworzy klucz }
Registry.WriteString('MyRegistryName','MyRegistry Value');   { zapisuje jego wartosc }
Registry.CloseKey;   { zamyka klucz i... }
Registry.Free;
end;

9.   Wyłączanie / włączanie Caps Locka / Num Locka / Scroll Locka

type   TKeyType = (ktCapsLock, ktNumLock, ktScrollLock);

procedure SetLedState(KeyCode: TKeyType; bOn: Boolean);
var KBState: TKeyboardState; Code: Byte;
begin
case KeyCode of   ktScrollLock: Code := VK_SCROLL;
ktCapsLock: Code := VK_CAPITAL;   ktNumLock: Code := VK_NUMLOCK;
end;
GetKeyboardState(KBState);
if (Win32Platform = VER_PLATFORM_WIN32_NT) then begin
if Boolean(KBState[Code]) < > bOn then begin
keybd_event(Code, MapVirtualKey(Code, 0), KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(Code, MapVirtualKey(Code, 0), KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;
end else begin  KBState[Code] := Ord(bOn);   SetKeyboardState(KBState);
end;   end;

// przykład...
procedure TForm1.Button1Click(Sender: TObject);
begin
SetLedState(ktCapsLock, True);   // CapsLock wł
SetLedState(ktNumLock, True);   // NumLock wl
SetLedState(ktScrollLock, True);   // ScrollLock wł
end;

10.   Usunięcie biblioteki DLL z pamięci

function KillDll(aDllName: string): Boolean;
var hDLL: THandle; aName: array[0..10] of char; FoundDLL: Boolean;
begin
StrPCopy(aName, aDllName);   FoundDLL := False;
repeat   hDLL := GetModuleHandle(aName);
if hDLL = 0 then   Break;   FoundDLL := True;   FreeLibrary(hDLL);
until   False;
if FoundDLL then   MessageDlg('Usunięta EUREKA!', mtInformation, [mbOK], 0)
else   MessageDlg('DLL nnie mogę usunąć!', mtInformation, [mbOK], 0);
end;

11.   Zmiana czasu systemowego komputera

{1. wersja dla Windows 9X/ME/NT/2000/XP}
function SetPCSystemTime(dDateTime: TDateTime): Boolean;
const SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
var hToken: THandle; ReturnLength: DWORD; tkp, PrevTokenPriv: TTokenPrivileges;
luid: TLargeInteger; dSysTime: TSystemTime;
begin
Result := False;   if (Win32Platform = VER_PLATFORM_WIN32_NT) then begin
if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then begin
try   if not LookupPrivilegeValue(nil, SE_SYSTEMTIME_NAME, luid) then   Exit;
tkp.PrivilegeCount := 1;   tkp.Privileges[0].luid := luid;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
if not AdjustTokenPrivileges(hToken, False, tkp, SizeOf(TTOKENPRIVILEGES), PrevTokenPriv, ReturnLength) then   Exit;
if (GetLastError < > ERROR_SUCCESS) then begin
raise   Exception.Create(SysErrorMessage(GetLastError));   Exit;   end;
finally   CloseHandle(hToken);   end; end; end;
DateTimeToSystemTime(dDateTime, dSysTime);
Result := Windows.SetLocalTime(dSysTime);
end;

{2. wersja dla win 2000 i późniejsze - bo zdarzenie WM_TIMECHANGE .......}
procedure TForm1.Button1Click(Sender: TObject);
var SystemTime: TSystemTime; NewTime, NewDate: string;
begin
NewTime := '13:58:00';   NewDate := '02.02.2001';   // or '02/02/01'
DateTimeToSystemTime(StrToDate(NewDate) + StrToTime(NewTime), SystemTime);
SetLocalTime(SystemTime);   // Tell windows, that the Time changed!
PostMessage(HWND_BROADCAST, WM_TIMECHANGE, 0, 0); // *
end;

{3. wersja .............}
function SetSystemTime(DateTime: TDateTime): Boolean;   { (c) by UNDO }
var tSetDati: TDateTime;   vDatiBias: Variant;  tTZI: TTimeZoneInformation;   tST: TSystemTime;
begin
GetTimeZoneInformation(tTZI);   vDatiBias := tTZI.Bias / 1440;   tSetDati := DateTime + vDatiBias;
with tST do begin
wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
wMonth := StrToInt(FormatDateTime('mm', tSetDati));
wDay := StrToInt(FormatDateTime('dd', tSetDati));
wHour := StrToInt(FormatDateTime('hh', tSetDati));
wMinute := StrToInt(FormatDateTime('nn', tSetDati));
wSecond := StrToInt(FormatDateTime('ss', tSetDati));
wMilliseconds := 0;
end;
Result := Windows.SetSystemTime(tST);
end;

12.   Kopiowanie łańcucha do / z schowka

uses ClipBrd;

procedure StrToClipbrd(StrValue: string);
var S: string; hMem: THandle; pMem: PChar;
begin
hMem := GlobalAlloc(GHND or GMEM_SHARE, Length(StrValue) + 1);
if hMem < > 0 then begin   pMem := GlobalLock(hMem);
if pMem < > nil then begin   StrPCopy(pMem, StrValue);   GlobalUnlock(hMem);
if OpenClipboard(0) then begin   EmptyClipboard;   SetClipboardData(CF_TEXT, hMem);
CloseClipboard;
end else   GlobalFree(hMem);
end else   GlobalFree(hMem);
end; end;

function GetStrFromClipbrd: string;
begin
if Clipboard.HasFormat(CF_TEXT) then   Result := Clipboard.AsText
else begin   ShowMessage('Teraz nie ma tekstu w schowku!');   Result := '';
end; end;

// zapisujemy "Hallo" do schowka i wyprowadzamy TOTO z niego
procedure TForm1.Button1Click(Sender: TObject);
begin
StrToClipbrd('Hallo');   ShowMessage(GetStrFromClipbrd);
end;

13.   Zawieszenie wykonania programu na określony czas

// Nie ma w Delphi zaimplementowanej procedury Delay. Można jako jej zamiennika użyć funkcji WinAPI o nazwie Sleep. Powoduje ona zawieszenie wykonania programu na określoną liczbę milisekund. Jednakże w tym czasie Twoja aplikacja nie będzie mogła obsługiwać komunikatów Windows. Dlatego też czasem lepszym rozwiązaniem jest użycie takiego kodu:

procedure TForm1.Button1Click(Sender: TObject);
var Teraz: TDateTime;
begin   // Tu wstawiamy operacje wykonywane przed pauzą
Teraz := Now;
repeat   // Pozwalamy aplikacji obsłużyć komunikaty
Application.ProcessMessages;   // 5 to liczba sekund pauzy
until Teraz+5/SecsPerDay < ;   Now;   // Tu operacje wykonywane po pauzie
end;

// Należy pamiętać o ważnej rzeczy: powyższy kod nie gwarantuje że inne procedury obsługi zdarzeń nie zostaną wykonane a tylko, że wykonanie kodu tej procedury zostanie wstrzymane na kilka sekund.

14.   Jak przy zamknięciu aplikacji poprosić użytkownika o potwierdzenie

Zdarzenie OnCloseQuery jest zdarzeniem formularza.

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin   //poniżej jest używana funkcja systemowa jako przykład użycia funkcji API
if messagebox(Form1.handle,'Czy chcesz zakończyć aplikację?',
'Potwierdzenie', MB_YESNO + MB_DEFBUTTON2 +
MB_SYSTEMMODAL +MB_ICONQUESTION + MB_TOPMOST)=IDNO then
CanClose:=False;
end;

15.   Przykład użycia asemblera do delphi.

public   { Public declarations }
function dodaj(a,b:word):word;stdcall;

function TForm1.dodaj(a,b:word):word;stdcall;
begin
asm     {funkcja dodaje do siebie dwie liczby, które najpierw trzeba zapisac na stos wartosci rejestrów które bedziemy używać}
push ax   {odklada na stos wartosc z ax - jako pierwsza}
push bx   {odklada na stos wartosc z bx - jako druga}
mov bx, b  {przypisujemy jednemu rejestrowi wartosc liczby 1}
mov ax, a   {przypisujemy drugiemu rejestrowi wartosci liczby 2}
add ax, bx   {dodajemy przy pomocy mnemonika " add " - cel zawsze ax}
mov @result, ax  {przypisujemy adresowi funkcji wartosc z ax}
pop bx   {pobieramy ze stosu wartosc rejestru bx - jako pierwszy bo ostatni zostal odlozony}
pop ax  {pobieramy ze stosu wartosc rejestru ax - jako drugi bo pierwszy zostal odlozony (przed bx)}
end; end;

//i przykład wykorzystania tej funkcji....
procedure TForm1.Button1Click(Sender: TObject);
var a,b,c:word;
begin
a:=StrToInt(Edit1.text);   b:=StrToInt(Edit2.text);
c:=dodaj(a,b);   edit3.text:=IntToStr(c);
end;

16.   Blokada wklejania tekstu w polu Memo.

Ignoruje kombinację Ctrl +V zapobiegając tym samym wklejaniu tekstu do, np. notatki służbowej

uses Clipbrd;
...
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if ((Key=Ord('V'))and(ssCtrl in Shift)) then begin
Clipboard.Clear;
Memo1.SelText:='Taki napis zamiast wklejanego tekstu';   //to w programie skasować!
Key:=0;
end;
end;

17.   Wykonanie zewnętrznego programu przez Windowsa.

procedure TForm1.Button1Click(Sender: TObject); begin
WinExec('calc.exe',SW_SHOWNORMAL);
end;

18.   Ukrycie / pokaz kursora myszy.

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowCursor(False);  // teraz kursor myszy bedzie ukryty
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowCursor(True);  // kursor jest znowu widoczny
end;

19.   Blokada kombinacji Ctrl+Alt+Delete pod XP - kombinacji restartu systemu XP.

procedure DisableTaskMgr(bTF: Boolean);
var reg: TRegistry;
begin
reg := TRegistry.Create;   reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey('Software', True);   reg.OpenKey('Microsoft', True);
reg.OpenKey('Windows', True);   reg.OpenKey('CurrentVersion', True);
reg.OpenKey('Policies', True);   reg.OpenKey('System', True);
if bTF = True then begin
reg.WriteString('DisableTaskMgr', '1');
end   else   if bTF = False then begin
reg.DeleteValue('DisableTaskMgr');
end;
reg.CloseKey;
end;

procedure TForm1.Button1Click(Sender: TObject);   //tak aktywować blokadę
begin
DisableTaskMgr(True);
end;

20.   Ograniczenie pola dla myszy do planszy programu.

procedure TForm1.Button1Click(Sender: TObject);
var Rect: TRect;
begin
Rect.Left := Left;
Rect.Top := Top;
Rect.Right := Left + Width;
Rect.Bottom := Top + Height;
ClipCursor(@Rect);
end;

//anulowanie ograniczenia z chwilą końca pracy z programem w procerurze OnClose
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ClipCursor(nil);
end;

21   Funkcja pokazująca nazwę komputera.

function GetComputerName: string;
var buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
Size: Cardinal;
begin
Size := MAX_COMPUTERNAME_LENGTH + 1;
Windows.GetComputerName(@buffer, Size);
Result := StrPas(buffer);
end;

// a takie wywołanie....
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetComputerName);
end;

22.   Funkcja pokazuje aktualną nazwę użytkownika komputera.

function GetCurrentUserName: string;
const cnMaxUserNameLen = 254;
var sUserName: string; dwUserNameLen: DWORD;
begin
dwUserNameLen := cnMaxUserNameLen - 1;
SetLength(sUserName, cnMaxUserNameLen);
GetUserName(PChar(sUserName), dwUserNameLen);
SetLength(sUserName, dwUserNameLen);
Result := sUserName;
end;

// a takie wywołanie....
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetCurrentUserName);
end;

23.   Pokaz ogólnej i dostępnej pamięci komputera.

procedure TForm1.Button1Click(Sender: TObject);
var memory: TMemoryStatus;
begin
memory.dwLength := SizeOf(memory);
GlobalMemoryStatus(memory);
ShowMessage('Pamięci ogólnej: ' + IntToStr(memory.dwTotalPhys) + ' Bajtów');
ShowMessage('Pamięć dostępna: ' + IntToStr(memory.dwAvailPhys) + ' Bajtów');
end;

24.   Ustawienie (zmiana nazwy) komputera.

function SetComputerName(AComputerName: string): Boolean;
var ComputerName: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
Size: Cardinal;
begin
StrPCopy(ComputerName, AComputerName);
Result := Windows.SetComputerName(ComputerName);
end;

// a takie wywołanie....
procedure TForm1.Button1Click(Sender: TObject);
begin
SetComputerName('Komp_Agaty');
end;

25.   Pokaz numeru seryjnyego dysku.

function GetHardDiskSerial(const DriveLetter: Char): string;
var NotUsed: DWORD; VolumeFlags: DWORD;
VolumeInfo: array[0..MAX_PATH] of Char;
VolumeSerialNumber: DWORD;
begin
GetVolumeInformation(PChar(DriveLetter + ':\'),
nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed, VolumeFlags, nil, 0);
Result := Format('Label = %s VolSer = %8.8X',
[VolumeInfo, VolumeSerialNumber])
end;

//wykonanie po aktywacji klawisza
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetHardDiskSerial('c'));
end;

26.   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.

27.   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.

28. 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;

29. 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;

30. 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;

31. Jak określić czas ostatniego dostępu do pliku?

Uwaga: nie wszystkie pliki systemowe dają się tak odczytać.
przykład:

procedure TForm1.Button1Click(Sender: TObject);
var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime;
begin
Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec);
if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime < > 0)
or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime < > 0))
then begin
FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);
FileTimeToSystemTime(DT,ST);
Memo1.Lines.Clear;
Memo1.Lines.Add('AutoExec.Bat was last accessed at:');
Memo1.Lines.Add('Year := ' + IntToStr(st.wYear));
Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth));
Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek));
Memo1.Lines.Add('Day := ' + IntToStr(st.wDay));
Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour));
Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute));
Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond));
Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds));
end;
SysUtils.FindClose(SearchRec);
end;

32. Jak znaleźć datę ostatniej modyfikacji pliku?

function GetFileDate(FileName: string): string;
var FHandle: Integer;
begin
FHandle := FileOpen(FileName, 0);
try
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally FileClose(FHandle);
end; end;

33. 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;

34. Wykaz (lista) uruchomionych w systemie aplikacji - przykład.

procedure TForm1.Button1Click(Sender: TObject);
var Wnd : hWnd; buff: ARRAY [0..127] OF Char;
begin
ListBox1.Clear;
Wnd := GetWindow(Handle, gw_HWndFirst);
WHILE Wnd < > 0 DO BEGIN {w osobnym oknie}
IF (Wnd < > Application.Handle) AND {niewidzialne okna}
IsWindowVisible(Wnd) AND {okna główne}
(GetWindow(Wnd, gw_Owner) = 0) AND {okna dziecka Child}
(GetWindowText(Wnd, buff, sizeof(buff)) < > 0){okna bez opisów}
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
ListBox1.Items.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
ListBox1.ItemIndex := 0;
end;

35. Sposoby ładowania bibliotek DLL - 2 statyczne i dynamiczne ładowanie:

Stwórzmy prostą bibliotekę dll w katalogu: c: \ np. \ exdouble \ exdouble.dpr (biblioteka exdouble);
/ / z taką jedynie funkcją
function calc_double(r: real): real; stdcall;
begin
result := r * 2; end; exports calc_double index 1;
end;

Teraz statyczne ładowanie dll:
W tej metodzie ładowania wystarczy umieścić plik w katalogu lub okna aplikacji, lub windows \ system, windows command \. Jeśli jednak system nie może znaleźć tego pliku w tym katalogu powinien pojawić się komunikat o błędzie (dll nie znaleziono, czy coś w tym duchu.)

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

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

var form1: tform1;
implementation
function calc_double(r: real): real; stdcall; external 'exdouble.dll';
{$r *.dfm}

procedure tform1.button1click(sender: tobject);
begin
//w oknie wiadomości będzie numer 21
showmessage(floattostr(calc_double(10.5)));
end; end.

Dynamiczne ładowanie dll - dla tego typu ładowania trzeba napisać trochę więcej kodu.
Ale wygląda na to:

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

type tcalc_double = function ( r: real ): real;
tform1 = class(tform)
button1: tbutton;
procedure button1click(sender: tobject);
private { private declarations }
public { public declarations }
end;

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

procedure tform1.button1click(sender: tobject);
var hnddllhandle: thandle; calc_double: tcalc_double;
begin
try // dynamicznie załadowanie dll
hnddllhandle := loadlibrary ( 'exdouble.dll' ); if hnddllhandle < > 0 then
begin
// uzyskanie adresu funkcji
@calc_double := getprocaddress ( hnddllhandle, 'calc_double' );
// jeżeli adres funkcji znaleziony
if addr ( calc_double ) < > nil then
begin
// pokaz wynik (21)
showmessage ( floattostr ( calc_double ( 10.5 ) ) );
end else
// dll nie znaleziono ("handleable")
showmessage ( 'funkcja nie istnieje...' );
end else
// dll nie znaleziono ("handleable") to
showmessage ( 'biblioteki dll nie znaleziono...' );
finally
// koniec i zwolnienie pamięci
freelibrary ( hnddllhandle );
end; end;
end.

36. Jak uzyskać pełną ścieżkę i nazwę pliku dll

uses windows;

procedure showdllpath stdcall;
var thefilename: array[0..max_path] of char;
begin
fillchar(thefilename, sizeof(thefilename), #0);
getmodulefilename(hinstance, thefilename, sizeof(thefilename));
messagebox(0, thefilename, 'the dll file name is:', mb_ok);
end;

37. Rejestracja Hot Key (gorących klawiszy) w systemie

Poniższy przykład pokazuje skróty klawiszowe i ich rejestrację w systemie.

unit unit1;
interface

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

type tform1 = class(tform)
procedure formcreate(sender: tobject);
procedure formdestroy(sender: tobject);
private { private declarations }
id1, id2, id3, id4: integer;
procedure wmhotkey(var msg: twmhotkey); message wm_hotkey;
public { public declarations }
end;

var form1: tform1;

implementation
{$r *.dfm}
//ustanowienie sposobu reakcji na hotkey - komunikaty
procedure tform1.wmhotkey(var msg: twmhotkey);
begin
if msg.hotkey = id1 then showmessage('ctrl + a pressed !');
if msg.hotkey = id2 then showmessage('ctrl + alt + r pressed !');
if msg.hotkey = id3 then showmessage('win + f4 pressed !');
if msg.hotkey = id4 then showmessage('print screen pressed !');
end;

procedure tform1.formcreate(sender: tobject);
// ustanowienie stałych
const mod_alt = 1; mod_control = 2; mod_shift = 4; mod_win = 8;
vk_a = $41; vk_r = $52; vk_f4 = $73;
begin
// register hotkey ctrl + a
id1 := globaladdatom('hotkey1');
registerhotkey(handle, id1, mod_control, vk_a);

// register hotkey ctrl + alt + r
id2 := globaladdatom('hotkey2');
registerhotkey(handle, id2, mod_control + mod_alt, vk_r);

// register hotkey win + f4
id3 := globaladdatom('hotkey3');
registerhotkey(handle, id3, mod_win, vk_f4);

// globally trap the windows system key "printscreen"
id4 := globaladdatom('hotkey4');
registerhotkey(handle, id4, 0, vk_snapshot);
end;

// wyrejestrowanie hotkeys z systemu z końcem pracy aplikacji
procedure tform1.formdestroy(sender: tobject);
begin
unregisterhotkey(handle, id1); globaldeleteatom(id1);
unregisterhotkey(handle, id2); globaldeleteatom(id2);
unregisterhotkey(handle, id3); globaldeleteatom(id3);
unregisterhotkey(handle, id4); globaldeleteatom(id4);
end;

end.
RegisterHotKey nie działa, jeśli klawisze określone dla skrótów są już zarejestrowane dla innego skrótu. W Windows NT4 i Windows 2000/XP: klawisze funkcyjne F1 do F12 są zarezerwowane przez debugger przez cały czas, więc nie powinny być rejestrowane jako klawisze skrótu. nawet gdy nie jest debugowanie aplikacji.

38. 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").

39. 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;

40. 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;

41. Zmiana daty systemowej

procedure TForm1.Button1Click(Sender: TObject);
begin
SetNewTime(2012, 2, 10, 18, 07);
end;

function SetNewTime(Ano, Mes, Dia, hour, minutes: word): Boolean;
var st:TSYSTEMTIME;
begin
GetLocalTime(st); st.wYear := Ano; st.wMonth := Mes; st.wDay := Dia;
st.wHour := hour; st.wMinute := minutes;
if not SetLocalTime(st) then Result := False
else
Result := True;
end;

42. BMP zapisane w pliku zasobów .RES

1. Utwórz plik tekstowy, na przykład: RECURSOS.RC o zawartości jak poniżej:
BITMAP_1 BITMAP "C: ImagensGrafico.bmp"
// dla wszystkich bitmap, że chcesz;
2. Kompilacja tego pliku BRCC32.EXE, że w katalogu bin Delphi będzie
RECURSOS.RES wygenerowany plik, a
3. Włóż do źródła projektu:
$ {R} RECURSOS.RES
// Aby korzystać z bitmap wykonaj następujące czynności:
VarTipoTBitmap: = LoadBitmap (hInstance, "BITMAP_1 ');

43. Umieszczenia funkcji w bibliotece DLL

Edytuj bezpośrednio w DPR, a następnie zapisz go jako Funcoes.dpr:

Library Funcoes;

Uses SysUtils,WinTypes,WinProcs;

{Funkcja, która kasuje spacje na początku i na końcu łańcucha}
Function Trim(J:String):String; Export;
Begin
While J[Length(J)]=#32 do Dec(J[0]);
If Length(J)> 1 then While (J[1]=' ') do Begin
Delete(J,1,1); If Length(J) <=1 then J:='';
end; Result:=J; end; Exports { Staje się widoczne dla programów}
Trim;
End.

Aby korzystać z programu:
Unit Unit1;
Interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons;

type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClick(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
VarForm1: TForm1;
Implementation

{ Deklaruje funkcję}
Function Trim(J:String):String; External 'funcoes.dll';
{$R *.DFM}

Procedure TForm1.FormClick(Sender: TObject);
begin
Caption:=Trim(' Zawsze możesz odwiedzić Delphi Club ');
end;

Korzyści z wprowadzenia funkcji w DLL są:
1. Program wymaga mniej linii kodu
2. Możliwość ponownego wykorzystania funkcji
3. W niektórych przypadkach można zaktualizować nie program a tylko dll

44. 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;

45. Jak uzyskać ze schowka tekst o dużej objętości?

Standardowa metoda Tclipboard.Astext ogranicza rozmiar tekstu rzędu - 255 bajtów. Aby otrzymać tekst dłuższy niż 255 bajtów należy użyć:

procedure getlargetext: pchar
var buffer: pchar; myhandle: thandle; textlength : integer;
begin
myhandle := clipboard.getashandle(cf_text); buffer := globallock(myhandle);
try result := nil; if buffer< > nil then
begin
{Teraz mamy typ danych PChar -- możemy więc pracować z nimi jak z konwencjonalnymi znakami NULL}
textlength := strlen(buffer); getmem(result, textlength+1); strcopy(buffer, result); end;
finally globalunlock(myhandle); end;
end;

46. Czyszczenie schowka

procedure clearclipboard;
begin
openclipboard(0); emptyclipboard; closeclipboard;
end;

47. Procedura przywracająca zapisany plik do schowka

procedure loadtoclipboardfrom(filename: string);
var h: thandle; p: pointer; cbf, cbblocklength: cardinal; i, cbcount: integer; fs: tfilestream;
begin
if openclipboard(0) then begin fs:=tfilestream.create(filename, 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;

48. Zapis schowka do pliku

procedure savefromclipboardto(filename: string);
var cbflist: tlist; i: integer; h: thandle; p: pointer;
cbblocklength, temp, cbf: 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; if cbflist.count > 0 then
begin
fs := tfilestream.create(filename, 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 > 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;

49. Praca z grafiką i schowkiem (Clipboard)

W tym przykładzie użyto Buttona, TImage i komponent TShape na formie. Gdy użytkownik kliknie Button, obraz zostaje przechowywany w postaci zmiennej formimage i zostaje skopiowany do schowka (clipboard). Obraz ze schowka jest następnie kopiowany z powrotem do TImage, tworząc ciekawy efekt.

procedure tform1.button1click(sender: tobject);
var 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;

Poniżej przykład kopiowania ekranu 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;

50. Śledzenie naciśnięcia klawiszy w systemie Windows

Aby śledzić najważniejsze wydarzenia w całym Windowsie, nalezy stworzyć uchwyt (hook) w pliku dll, w którym umiescic 3 funkcje: tworzenie pułapek, zdarzenie obsługi wciśnięcia klawisza i zniszczenie pułapki.
Poniżej tekst pliku dll:

library key;
uses wintypes, winprocs, messages;
const keyevent = wm_user + 1;

var hookhandle: hhook;

function keyhook(code: integer; wparam: word; lparam: longint): longint;
var wnd: hwnd;
begin
if code >= 0 then begin wnd := findwindow('tkeyform', nil);
sendmessage(wnd, keyevent, wparam, lparam); result := 0;
end else
result := callnexthookex(hookhandle, code, wparam, lparam);
end;

procedure setkeyhook;
begin
hookhandle := setwindowshookex(wh_keyboard, @keyhook, hinstance, 0);
end;

procedure delkeyhook;
begin
if hookhandle < > 0 then unhookwindowshookex(hookhandle);
end;

exports
setkeyhook index 1, keyhook index 2, delkeyhook index 3;
begin
end.

Niżej kod programu. Ważne jest, aby wywołać w pliku głównym keyform - inaczej nic nie będzie działać.

unit keyun;

interface

uses wintypes, messages, forms, sysutils;
const keyevent = wm_user + 1;

type tkeyform = class(tform)
procedure formcreate(sender: tobject);
procedure formdestroy(sender: tobject);
private
procedure wm_nextmsg(var msg: tmessage); message keyevent;
public
hlib: thandle;
end;

var keyform: tkeyform;

implementation
{$r *.dfm}
function setkeyhook: longint; external 'key' index 1;
function keyhook: longint; external 'key' index 2;
function delkeyhook: longint; external 'key' index 3;

procedure tkeyform.wm_nextmsg(var msg: tmessage);
begin
beep;
end;

procedure tkeyform.formcreate(sender: tobject);
begin
hlib := loadlibrary('key.dll'); setkeyhook;
end;

procedure tkeyform.formdestroy(sender: tobject);
begin
delkeyhook; freelibrary(hlib);
end;

end.

51. Szpieg naciskania klawiszy klawiatury

library kbdhook;
uses sysutils, windows, messages;
const swm_kbdhook = 'swm_kbdhook';
var wm_kbdhook : integer = 0;
var hookhandle : thandle = 0;

function keyboardproc(
code: integer; // kod uchwytu
wparam: wparam; //kod wirtualnego klawisza virtual-key
lparam: lparam): // informacja po naciśnieciu
lresult stdcall;
begin
if code < 0 then result := callnexthookex( hookhandle, code, wparam, lparam )
else begin
postmessage( hwnd_broadcast, wm_kbdhook, wparam, lparam ); result := 0
end; end;

function hookkeyboard( hook : boolean ) : boolean; stdcall;
begin
result := false; if hook then begin
if hookhandle = 0 then
hookhandle := setwindowshookex( wh_keyboard, keyboardproc, hinstance, 0 );
result := ( hookhandle < > 0 );
end else begin
if hookhandle < > 0 then begin unhookwindowshookex( hookhandle );
hookhandle := 0; result := true;
end; end; end;

exports
keyboardproc index 1, hookkeyboard index 2;

begin
wm_kbdhook := registerwindowmessage( swm_kbdhook );
end.
---------------------------------------------------------------------
unit unit1;

interface

uses windows, messages, sysutils, classes, graphics, controls, forms, dialogs, stdctrls;
const swm_kbdhook = 'swm_kbdhook';

var wm_kbdhook : integer = 0;

type tform1 = class(tform)
checkbox1: tcheckbox;
memo1: tmemo;
procedure checkbox1click(sender: tobject);
procedure formdestroy(sender: tobject);
procedure formcreate(sender: tobject);
private { private declarations }
procedure apponmessage( var msg: tmsg; var handled: boolean);
public { public declarations }
end;

var form1: tform1;

implementation
{$r *.dfm}
function keyboardproc(
code: integer; // kod uchwytu
wparam: wparam; //kod wirtualnego klawisza virtual-key
lparam: lparam): // informacja po naciśnieciu
lresult stdcall;
external 'kbdhook.dll' index 1;

function hookkeyboard( hook : boolean ) : boolean; stdcall; external 'kbdhook.dll' index 2;

procedure tform1.apponmessage( var msg: tmsg; var handled: boolean);
begin
if msg.message = wm_kbdhook then begin
memo1.lines.add( format( 'keycode=%d flags=%d', [msg.wparam, msg.lparam] ) );
handled := true; end;
end;

procedure tform1.checkbox1click(sender: tobject);
begin
if not hookkeyboard( ( sender as tcheckbox ).checked )
then caption := 'Błąd!';
end;

procedure tform1.formdestroy(sender: tobject);
begin
hookkeyboard( false );
end;

procedure tform1.formcreate(sender: tobject);
begin
wm_kbdhook := registerwindowmessage( swm_kbdhook );
application.onmessage := apponmessage;
end;

end.

52. 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;

53. Jak symulować ruch myszy?

W przykładzie, mysz lekko popychana bez interwencji użytkownika.

procedure tform1.button1click(sender: tobject);
var pt : tpoint;
begin
application.processmessages; screen.cursor :=crhourglass;
getcursorpos(pt); setcursorpos(pt.x + 1, pt.y + 1);
application.processmessages; setcursorpos(pt.x - 1, pt.y - 1);
end;

54. Jak emulować naciśnięcia klawisza lub kliknięcia myszką.

procedure mouseclick(pt: tpoint; backcursor: boolean = true);

/ / Tłumaczenie współrzędnych ekranu na przyjętych w mouse_event
function screentoabsolute(const pt: tpoint): tpoint;
begin
result.x := round(pt.x * 65535 / screen.width);
result.y := round(pt.y * 65535 / screen.height);
end;
var oldpt: tpoint;
begin
if backcursor then oldpt := screentoabsolute(mouse.cursorpos);
pt := screentoabsolute(pt); {Przesunięcie kursora}
mouse_event(mouseeventf_absolute or mouseeventf_move, pt.x, pt.y, 0, 0);
{naciśnięty lewy przycisk myszy}
mouse_event(mouseeventf_absolute or mouseeventf_leftdown, pt.x, pt.y, 0, 0);
{Przytrzymany wciśnięty lewy przycisk myszy}
mouse_event(mouseeventf_absolute or mouseeventf_leftup, pt.x, pt.y, 0, 0);
if backcursor then {Przesuń mysz z powrotem}
mouse_event(mouseeventf_absolute or mouseeventf_move, oldpt.x, oldpt.y, 0, 0);
end;

Przykład: umieścić w postaci dwóch przycisków button1 i button2 i dla ich ich obsługi, wpisać:

procedure tform1.button1click(sender: tobject);
begin
showmessage('Testuję Aniele');
end;

procedure tform1.button2click(sender: tobject);
begin
mouseclick(button1.clienttoscreen(point(2, 2)), true); // Kliknij na pierwszy przycisk ...
end;

55. Emulacja naciśnięcia klawisza.

Wewnątrz aplikacji, można to zrobić w bardzo prosty sposób poprzez wywołanie Windows API SendMessage () (można użyć i wykonać metody obiektu (lub formy), który wysłał wiadomość klucz).
kod: memo1.perform(wm_char, ord('a'), 0);
lub sendmessage(memo1.handle, wm_char, ord('a'), 0);//wpisze literę a w polu memo1

Przechwytywanie klawiszy w aplikacji.
Problem został rozwiązany w bardzo prosty sposób. Można ustawić właściwość w KeyPreview postaci True i wykorzystać zdarzenie Onkeypress. Drugi sposób - do przechwytu stosować Onmessage dla aplikacji.

56. Jak nie dopuścić do uruchomienia drugiej kopii programu?

program Previns;

uses WinTypes, WinProcs, SysUtils, Forms, Uprevins in 'UPREVINS.PAS' {Form1};
{$R *.RES}

type PHWND = ^HWND;

function EnumFunc(Wnd:HWND; TargetWindow:PHWND) : bool; export;
var ClassName : array[0..30] of char;
begin
Result := true; if GetWindowWord(Wnd,GWW_HINSTANCE) = hPrevInst then
begin
GetClassName( Wnd, ClassName, 30 ); if StrIComp( ClassName, 'TApplication' ) = 0 then
begin
TargetWindow^ := Wnd; Result := false; end; end;
end;

procedure GotoPreviousInstance;
var PrevInstWnd : HWND;
begin
PrevInstWnd := 0; EnumWindows( @EnumFunc, Longint( @PrevInstWnd ) );
if PrevInstWnd < > 0 then if IsIconic( PrevInstWnd ) then
ShowWindow( PrevInstWnd, SW_RESTORE )
else BringWindowToTop( PrevInstWnd ); end;
begin
if hPrevInst < > 0 then GotoPreviousInstance
else begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.

57. Jak ustalić, czy są naciskane klawisze Shift, Alt lub Ctrl?

Poniższy przykład pokazuje, jak ustalić, czy naciśnięty klawisz Shift podczas wybierania wiersza menu.Przykład zawiera także klawisze stan funkcji Alt, Ctrl.

function CtrlDown : Boolean;
var State : TKeyboardState;
begin
GetKeyboardState(State); Result := ((State[vk_Control] And 128) < > 0);
end;

function ShiftDown : Boolean;
var State : TKeyboardState;
begin
GetKeyboardState(State); Result := ((State[vk_Shift] and 128) < > 0);
end;
function AltDown : Boolean;
var State : TKeyboardState;
begin
GetKeyboardState(State); Result := ((State[vk_Menu] and 128) < > 0);
end;

procedure TForm1.MenuItem12Click(Sender: TObject);
begin
if ShiftDown then Form1.Caption := 'Shift' else Form1.Caption := '';
end;

58. Dostęp do tymczasowego katalogu Windows.

function sysdir:string;
var buf:array[0..max_path] of char;
begin
getsystemdirectory(@buf, max_path+1); result := buf;
end;

function tempdir:string;
var buf:array[0..max_path] of char;
begin
gettemppath(max_path+1, @buf); result := buf;
end;

59. Jak ustalić numer seryjny systemu plików.

procedure tform1.button1click(sender: tobject);
var serialnum: pdword; a,b: dword; buffer: array [0..255] of char;
begin
new(serialnum);
if getvolumeinformation('c:\',buffer,sizeof(buffer),serialnum,a,b,nil,0) then
label1.caption:=inttostr(serialnum^); dispose(serialnum);
end;

60. Określić, czy dokonano zmiany ustawienia ekranu.

type {...}
private
procedure wmdisplaychange(var msg: tmessage);
message wm_displaychange;
public {...}
end; end;

var form1: tform1;

implementation
{$r *.dfm}

procedure tform1.wmdisplaychange(var msg: tmessage);
begin
showmessage('wyswietlanie ekranu zmienione!');
inherited;
end;

61.Określenie ścieżek do schowka, autorun, pulpitu, moje dokumenty, itp.

Do tego służy funkcja winapi shgetspecialfolderlocation.
Przykład użycia:

uses shlobj;

procedure tform1.formcreate(sender: tobject);
const folders: array [0..15] of integer = (csidl_bitbucket,csidl_controls,csidl_desktop,
csidl_desktopdirectory,csidl_drives,csidl_fonts, csidl_nethood,csidl_network,
csidl_personal,csidl_printers,csidl_programs,csidl_recent,csidl_sendto,csidl_startmenu,
csidl_startup,csidl_templates);

vars: pchar;p: pitemidlist;i: integer;
begin
s := stralloc(128);
for i := low(folders) to high(folders) do begin
p := nil;
shgetspecialfolderlocation(form1.handle, folders[i], p);
shgetpathfromidlist(p, s); listbox1.items.add(s);
end; end;

62. Ustawienie tapety dla ekranu Windowsa

Informacje o obrazie, który znajduje się na pulpicie, oczywiście, można znaleźć w rejestrze! Znajduje się w kluczu HKEY_CURRENT_USER, ale może dostać się do takiej ścieżki:
hkey_current_usercontrol paneldesktop
Parametr, który zawiera nazwę obrazu nosi nazwę "wallpaper". Oznacza to, że aby zmienić tapetę musimy zmienić wartość "wallpaper" i powiedzieć systemowi, by takie zmiany wprowadził do rejestru.
Do sekcji uses musimy dołączyć 2 moduły: registry.pas i winprocs.pas. W przykladzie potrzebujemy tylko 1 przycisku z funkcją zmiany tapety:

unit unit1;

interface

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

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

var form1: tform1;

implementation
{$r *.dfm}

procedure setwallpaper(swallpaperbmppath : string; btile : boolean );
var reg : treginifile;
begin
// modyfikujemy klucz rejestru hkey_current_usercontrol paneldesktop
// tilewallpaper (reg_sz)
// wallpaper (reg_sz)
reg := treginifile.create('control paneldesktop' );
with reg do begin
writestring( '', 'wallpaper', swallpaperbmppath );
if( btile )then begin
writestring('', 'tilewallpaper', '1' );
end else begin
writestring('', 'tilewallpaper', '0' );
end; end;
reg.free;
// informuje wszystkich, że zmiana konfiguracji systemu
systemparametersinfo(spi_setdeskwallpaper, 0, nil, spif_sendwininichange );
end;

procedure tform1.button1click(sender: tobject);
begin
setwallpaper('c:windows1stboot.bmp', false );
end;

end.

Ale musimy pamiętać, że kod ten działa tylko przy odłączonym activedesctop. Jeśli masz włączony, czy chcesz zainstalować na pulpicie format obrazu. GIF JPG lub., Będzie trzeba użyć poniższy kod:

uses comobj, shlobj;

procedure changeactivewallpaper;
const clsid_activedesktop: tguid = '{75048700-ef1f-11d0-9888-006097deacf9}';
var activedesktop: iactivedesktop;
begin
activedesktop := createcomobject(clsid_activedesktop) as iactivedesktop;
activedesktop.setwallpaper('c:windowsforest.bmp',0);
activedesktop.applychanges(ad_apply_all or ad_apply_force);
end;

63. Lista uruchomionych aplikacji - kolejna wersja.

procedure tform1.button1click(sender: tobject);
var wnd: hwnd; buff: array [0..127] of char;
begin
listbox1.clear; wnd := getwindow(handle, gw_hwndfirst);
while wnd < > 0 do begin // nie pokazuj
if (wnd < > application.handle) //własnych okien
and iswindowvisible(wnd) // i okien ukrytych
and (getwindow(wnd, gw_owner) = 0) // i okienChild
and (getwindowtext(wnd, buff, sizeof(buff)) < > 0) then begin
getwindowtext(wnd, buff, sizeof(buff));
listbox1.items.add(strpas(buff));
end;
wnd := getwindow(wnd, gw_hwndnext);
end;
listbox1.itemindex := 0;
end;

64. Jak uzyskać wykazy wszystkich procesów uruchomionych w systemie

Pod Windows (Win32) jest możliwe przy użyciu funkcji pomocniczych informacji:
hsnapshot: = createtoolhelp32snapshot (th32cs_snapprocess, 0);
process32first () - daje informacje na temat pierwszego procesu w wykazie;
process32next() - daje informacje na temat następnego procesu na liście.

unit kernlutl;

interface

uses tlhelp32, windows, classes, sysutils;

procedure getprocesslist(list: tstrings);
procedure getmodulelist(list: tstrings);
function getprocesshandle(processid: dword): thandle;
procedure getparentprocessinfo(var id: dword; var path: string);

const
process_terminate = $0001;
process_create_thread = $0002;
process_vm_operation = $0008;
process_vm_read = $0010;
process_vm_write = $0020;
process_dup_handle = $0040;
process_create_process = $0080;
process_set_quota = $0100;
process_set_information = $0200;
process_query_information = $0400;
process_all_access = standard_rights_required or synchronize or $0fff;

implementation

procedure getprocesslist(list: tstrings);
var i: integer; hsnapshoot: thandle; pe32: tprocessentry32;
begin
list.clear; hsnapshoot := createtoolhelp32snapshot(th32cs_snapprocess, 0);
if (hsnapshoot = -1) then exit; pe32.dwsize := sizeof(tprocessentry32);
if (process32first(hsnapshoot, pe32)) then repeat
i := list.add(format('%x, %x: %s', [pe32.th32processid, pe32.th32parentprocessid, pe32.szexefile]));
list.objects[i] := pointer(pe32.th32processid);
until not process32next(hsnapshoot, pe32); closehandle (hsnapshoot);
end;

procedure getmodulelist(list: tstrings);
var i: integer; hsnapshoot: thandle; me32: tmoduleentry32;
begin
list.clear; hsnapshoot := createtoolhelp32snapshot(th32cs_snapmodule, 0);
if (hsnapshoot = -1) then exit; me32.dwsize := sizeof(tmoduleentry32);
if (module32first(hsnapshoot, me32)) then repeat
i := list.add(me32.szmodule); list.objects[i] := pointer(me32.th32moduleid);
until not module32next(hsnapshoot, me32); closehandle (hsnapshoot);
end;

procedure getparentprocessinfo(var id: dword; var path: string);
var processid: dword; hsnapshoot: thandle; pe32: tprocessentry32;
begin
processid := getcurrentprocessid; id := 0; path := '';
hsnapshoot := createtoolhelp32snapshot(th32cs_snapprocess, 0);
if (hsnapshoot = -1) then exit;
pe32.dwsize := sizeof(tprocessentry32); if (process32first(hsnapshoot, pe32)) then
repeat if pe32.th32processid = processid then
begin
id := pe32.th32parentprocessid; break;
end;
until not process32next(hsnapshoot, pe32); if id < > -1 then
if (process32first(hsnapshoot, pe32)) then repeat
if pe32.th32processid = id then
begin
path := pe32.szexefile; break;
end;
until not process32next(hsnapshoot, pe32); closehandle (hsnapshoot);
end;

function getprocesshandle(processid: dword): thandle;
begin
result := openprocess(process_all_access, true, processid);
end;

end.

65. Programowe zamykania systemu Windows - wersja nikolajew igora.

Przy pomocy 1 komponentu zamykamy system, uruchamiamy do ponownie, kończymy sesję użytkownika , mamy funkcję wysuwania cd, wyłączania monitora, itp.
Przykład:

procedure tform1.button1click(sender: tobject);
begin
powercontrol1.action := actcdeject; // lub... actlogoff, actshutdown...
powercontrol1.execute;
end;

unit powercontrol;

interface

uses windows, messages, sysutils, classes, controls, forms, graphics, mmsystem;

type
taction = (actlogoff, actshutdown, actreboot, actforce,actpoweroff, actforceifhung, actmonitoroff,
actmonitoron, actcdeject, actcduneject);
tpowercontrol = class(tcomponent)
private
faction: taction;
procedure setaction(value: taction);
public
function execute: boolean;
published
property action: taction read faction write setaction;
end;

procedure register;

implementation

procedure register;
begin
registercomponents('k2', [tpowercontrol]);
end;

procedure tpowercontrol.setaction(value: taction);
begin
faction := value;
end;

function tpowercontrol.execute: boolean;
begin
with (owner as tform) do case faction of
actlogoff: exitwindowsex(ewx_logoff,1); actshutdown: exitwindowsex(ewx_shutdown,1);
actreboot: exitwindowsex(ewx_reboot,1); actforce: exitwindowsex(ewx_force,1);
actpoweroff: exitwindowsex(ewx_poweroff,1); actforceifhung: exitwindowsex(ewx_forceifhung,1);
actmonitoroff: sendmessage(application.handle, wm_syscommand, sc_monitorpower, 0);
actmonitoron: sendmessage(application.handle, wm_syscommand, sc_monitorpower, -1);
actcdeject: mcisendstring('set cdaudio door open wait', nil, 0, handle);
actcduneject: mcisendstring('set cdaudio door closed wait', nil, 0, handle);
end; {case}
result := true;
end;

end.

66. Dodawanie elementów do menu systemu Windows wersja X.

Prawdopodobnie zastanawiasz się, dlaczego w menu systemu zawsze takie same? Poniższy przykład pokazuje jak dodać z powrotem takich pozycji, jak "about" lub "informacjon", lub coś innego. Potrzebne są dwie rzeczy, pierwsza to element id, który może być dowolną liczbą całkowitą. Druga to opis (Caption) do naszego menu. Potrzebujemy również procedury, która otrzyma wiadomości gdy aktywujemy (klik) to menu.

unit ohyeah;
interface

uses sysutils, wintypes, winprocs, messages, classes, graphics, controls, forms, dialogs, menus;

type tform1 = class (tform)
procedure formcreate (sender : tobject);
private {private declarations}
public {public declarations}
procedure winmsg (var msg : tmsg; var handled : boolean);
procedure dowhateever;
end;

var form1 : tform1;

implementation
{$r *.dfm}
const itemid = 99; // id numer pozycji w menu - może być dowolny

procedure tform1.winmsg (var msg : tmsg; var handled : boolean);
begin
if msg.message = wm_syscommand then
if msg.wparam = itemid then dowhatever;
end;

procedure tform1.formcreate (sender : tobject);
begin
application.onmessage := winmsg;
appendmenu (getsystemmenu (form1.handle, false), mf_separator, 0, '');
appendmenu (getsystemmenu (form1.handle, false), mf_byposition, itemid, 'Moje menu');
appendmenu (getsystemmenu (application.handle, false), mf_separator, 0, '');
appendmenu (getsystemmenu (application.handle, false), mf_byposition, itemid,'Moje menu minimized');
end;

procedure tform1.dowhatever;
begin
exit; // tu dołączyć można wszystko co nam się podoba!!!
end;
end. // autor mad rodrguez mail@mad666.net

67. Odczyt numeru seryjnego dysku - 3 warianty

1.
Function GetVolumeInfoFVS(Const Dir:string;
Var FileSystemName,VolumeName:string;Var Serial:longint):boolean;
{pobieranie informacji o dysku
Dir - katalog lub wybrana partycja dysku
FileSystemName - nazwa systemu plików
VolumeName - etykieta dysku
Serial - numer seryjny dysku - w przypadku błędu funkcja zwraca False}
var root:pchar; res:longbool;
VolumeNameBuffer,FileSystemNameBuffer:pchar;
VolumeNameSize,FileSystemNameSize:DWord;
VolumeSerialNumber,MaximumComponentLength,FileSystemFlags:DWORD;
s:string; n:integer;
Begin
n:=pos(':',Dir); If n > 0 Then s:=copy(Dir,1,n+1) Else s:=s+':';
If s[length(s)]=':' Then s:=s+'\'; root:=pchar(s);
getMem(VolumeNameBuffer,256); getMem(FileSystemNameBuffer,256);
VolumeNameSize:=255; FileSystemNameSize:=255;
res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize
,@VolumeSerialNumber, MaximumComponentLength, FileSystemFlags
,FileSystemNameBuffer,FileSystemNameSize);
Result:=res;
VolumeName:=VolumeNameBuffer; FileSystemName:=FileSystemNameBuffer;
Serial:=VolumeSerialNumber;
freeMem(VolumeNameBuffer,256); freeMem(FileSystemNameBuffer,256);
End;

2.
Function GetHDSerNo: shortstring; export;
var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : Cardinal; MaxComponentLength, FileSystemFlags : DWORD;
Begin
Try GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
Result:=IntToHex(HiWord(VolumeSerialNo),4)+ '-'+IntToHex(LoWord(VolumeSerialNo),4);
Except;
End; End

3.
Procedure TForm1.Button1Click(SEnder: TObject);
var VolumeName,FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;MaxComponentLength, FileSystemFlags : Cardinal;
Begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags,FileSystemName,MAX_PATH);
Memo1.Lines.Add('VName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
End;

68. Programowa regulacja jasności i kontrastu monitora.

unit unit1;

interface

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

type tform1 = class(tform)
button1: tbutton;
button2: tbutton;
procedure button1click(sender: tobject);
procedure button2click(sender: tobject);
procedure formcreate(sender: tobject);
procedure formdestroy(sender: tobject);
private { private declarations }
public { public declarations }
end;

var form1: tform1;

implementation
{$r *.dfm}
type tramparray=array[0..2] of array[byte] of word; //tablica przechowuje gamma kolorów
var origramparray:tramparray; // aktualne wartości gammy

//funkcja zmiany jasności - wbrightness - tym jaśniejszy
function setbrightness(wbrightness:word):boolean;
var ramparray:tramparray; i, value:integer; dc:hdc;
begin
for i:=0 to maxbyte do
begin
value := i * (wbrightness + 128); if (value > maxword) then value := maxword;
ramparray[0][i] := value; ramparray[1][i] := value; ramparray[2][i] := value;
end;
dc:=getdc(0); try result:= setdevicegammaramp(dc,ramparray)
finally releasedc(0,dc)
end end;

// zachowuje aktualne wartości gamma
procedure tform1.formcreate(sender: tobject);
var dc:hdc;
begin
dc:=getdc(0);
try getdevicegammaramp(dc,origramparray)
finally releasedc(0,dc)
end end;

// zmieniamy jasność
procedure tform1.button1click(sender: tobject);
begin
setbrightness(64)
end;

// przywracamy poprzednią gamme kolorów
procedure tform1.button2click(sender: tobject);
var dc:hdc;
begin
dc:=getdc(0);
try setdevicegammaramp(dc,origramparray)
finally releasedc(0,dc)
end end;

procedure tform1.formdestroy(sender: tobject);
begin
button2click(button2)
end;

end.

69. Dodawanie komponentów do standardowego okna dialogowego

Przykład pokazuje standardowe okno dialogowe, które posiada dodatkowy znacznik wyboru - "Nie pokazuj tego komunikatu ponownie". Rozwiązanie przydatne przy pracy z grafiką a jest to możliwe przy wykorzystaniu funkcji createmessagedialog i dodanie składnika przez wywołanie showmodal.
na przykład:

procedure tform1.button1click(sender: tobject);
var amsgdialog: tform; acheckbox: tcheckbox;
begin
amsgdialog := createmessagedialog('to jest test komunikatu.', mtwarning, [mbyes, mbno]);
acheckbox := tcheckbox.create(amsgdialog);
with amsgdialog do
try caption := 'Tytuł okienka' ; height := 169;
with acheckbox do
begin
parent := amsgdialog; caption := 'Nie pokazuj tego ponownie.';
top := 121; left := 8;
end;

case showmodal of
id_yes: ;//tutaj kod gdy okno dialogowe zostanie zamknięte
id_no: ;
end;
if acheckbox.checked then begin
//...
end; finally acheckbox.free; free;
end; end;

70. Robota z datami.

data - d (dzień), m (miesiąc), y (rok).
numer dnia tygodnia: poniedziałek - 1, wtorek - 2, niedziela - 7.
uses math, ap;

function dayofweek(d : integer; m : integer; y : integer):integer;forward;

Dzień tygodnia według daty.
function dayofweek(d : integer; m : integer; y : integer):integer;
var n : integer;
begin
if m >2 then begin m := m+1;
end else begin
m := m+13; y := y-1;
end;
n := 36525*y div 100+306*m div 10+d-621050; result := n-n div 7*7+1;
end;

Ilość dni między dwiema datami -date2 i date1
uses math, api;

function daysbetween(d1 : integer; m1 : integer; y1 : integer; d2 : integer;
m2 : integer; y2 : integer) : integer; forward;

function daysbetween(d1 : integer; m1 : integer; y1 : integer; d2 : integer;
m2 : integer; y2 : integer):integer;
var n1 : integer; n2 : integer;
begin
if m1 >2 then begin m1 := m1+1;
end else begin
m1 := m1+13; y1 := y1-1;
end;
n1 := 36525*y1 div 100+306*m1 div 10+d1; if m2 >2 then
begin
m2 := m2+1; end else begin
m2 := m2+13; y2 := y2-1;
end;
n2 := 36525*y2 div 100+306*m2 div 10+d2; result := n2-n1;
end;

Ilość lat, miesięcy i dni między dwiema datami
uses math, ap;

procedure dmybetween(const d2 : integer; const m2 : integer; const y2 : integer;
const d1 : integer; const m1 : integer; const y1 : integer; var d : integer;
var m : integer; var y : integer);forward;

Liczbę lat, miesięcy i dni pomiędzy dwiema datami - data1 i data2.
procedure dmybetween(const d2 : integer; const m2 : integer; const y2 : integer; const d1 : integer;
const m1 : integer; const y1 : integer; var d : integer; var m : integer; var y : integer);
var yleap : boolean; dm : tinteger1darray; cf : integer;
begin
setlength(dm, 12+1); yleap := (y2 mod 4=0) and ((y2 mod 100 < > 0) or (y2 mod 400=0));
dm[1] := 31; dm[3] := 31; dm[4] := 30; dm[5] := 31; dm[6] := 30; dm[7] := 31; dm[8] := 31;
dm[9] := 30; dm[10] := 31; dm[11] := 30; dm[12] := 31;
if yleap then
begin
dm[2] := 29; end else begin dm[2] := 28; end;
cf := 0; d := d1-d2; if d <0 then
begin
d := d+dm[m2]; cf := 1; end;
m := m1-m2-cf; cf := 0; if m < 0 then
begin
m := m+12; cf := 1; end; y := y1-y2-cf;
end;

Sprawdzenie, czy rok jest przestępny. Program sprawdza czy rok jest przestępny. Ten rok to taki, który dzieli się prze 4 ale nie dzieli się przez 100 chociaż dzieli się przez 400 - stąd:
yleap := (y2 mod 4=0) and ((y2 mod 100 < > 0) or (y2 mod 400=0));

71.Jak wdrożyć w Windows dokładny (ułamkowy) pomiar czasu?

Sam Windows nie pokazuje dokladnego czasu. Za pomocą procedury QueryPerformanceCounter można osiągnąć dokładność rzędu kilku nanosekund. Oto przykład:

var waitcal: int64;

procedure wait(ns: integer);
var counter, freq, waituntil: int64;
begin
if queryperformancecounter(counter) then
begin
queryperformancefrequency(freq);
waituntil := counter + waitcal + (ns * (freq div 1000000));
while counter < waituntil do
queryperformancecounter(counter);
end else sleep(ns div 1000);
end;
// aby uzyskać większą dokładność należy poczekać (sleep) chwilę przed użyciem wait()
var start, finish: int64;
application.processmessages; sleep(10);
queryperformancecounter(start); wait(0);
queryperformancecounter(finish); waitcal := start - finish;

//jeżeli nie stwierdzi się zwiększenia dokładności to można spróbować tak:
application.processmessages;
sleep(0); dosomething; wait(10); dosomethingelse;

72. Praca z czasem i sposoby dodawania czasu typu 1.20+1.50=3.10

Jeśli tworzysz aplikację, w której użytkownik wprowadzi wartość czasu, standardowe obliczenia nie będą działać. Problem w tym, że w normalnym trybie dla komputera wyrażenia 1.20 + 1.70 wyniesie 2,90, a nie 3.10. Oto trzy funkcje, które rozwiązują problem. One pracują tylko z godzinami i minutami ponieważ użytkownicy rzadko wykorzystują sekundy. Druga i trzecia funkcja pozwalają na konwersję rzeczywistą wartości czasu do dziesiętny odpowiednik i vice versa. Wszystkie pola na formularzu będą w formacie hh.mm.

function sumhhmm(a, b: double): double;
var h1: double;
begin
h1 := (int(a) + int(b)) * 60 + (frac(a) + frac(b)) * 100;
result := int(h1 / 60) + (h1 - int(h1 / 60) * 60) / 100;
end;

function hhmm2hhdd(const hhmm: double): double;
begin
result := int(hhmm) + (frac(hhmm) / 0.6);
end;

function hhdd2hhmm(const hhdd: double): double;
begin
result := int(hhdd) + (frac(hhdd) * 0.6);
end;

//zastosowanie:
// sumtime(1.20,1.50) => 3.10
// sumtime(1.20,- 0.50) => 0.30
// hhmm2hhdd(1.30) => 1.5 (1h.30m = 1.5h)
// hhdd2hhmm(1.50) => 1.30 (1.5h = 1h30m)

73. Jak obliczyć wiek po dniu urodzin?

{ brthdate: data urodzin }
function tffuncs.calcage(brthdate: tdatetime): integer;
var month, day, year, bmonth, bday, byear: word;
begin
decodedate(brthdate, byear, bmonth, bday);
if bmonth = 0 then result := 0
else begin
decodedate(date, year, month, day); result := year - byear;
if (100 * month + day) < (100 * bmonth + bday) then
result := result - 1;
end; end;

procedure tform1.button1click(sender: tobject);
var month, day, year, currentmonth, currentday, currentyear: word; age: integer;
begin
decodedate(datetimepicker1.date, year, month, day);
decodedate(date, currentyear, currentmonth, currentday);
if (year = currentyear) and (month = currentmonth) and (day = currentday) then age := 0
else begin
age := currentyear - year;
if (month > currentmonth) then dec(age)
else
if month = currentmonth then if (day > currentday) then dec(age); end;
label1.caption := inttostr(age);
end;
// sprawdzenie czy data aktualna
function dateexists(date: string; separator: char): boolean;
var olddateseparator: char;
begin
result := true; olddateseparator := dateseparator;
dateseparator := separator;
try try strtodate(date);
except
result := false; end;
finally dateseparator := olddateseparator;
end; end;

procedure tform1.formcreate(sender: tobject);
begin
if dateexists('35.3.2001', '.') then
begin
{tutaj wstaw swój kod.......}
end; end;

74. Jak otrzymać datę według kalendarza Juliańskiego?

function julian(year, month, day: integer): real;
var yr, mth: integer; noleap, leap, days, yrs: real;
begin
if year < 0 then yr := year + 1
else
yr := year; mth := month; if (month < 3) then
begin
mth := mth + 12; yr := yr - 1; end;
yrs := 365.25 * yr; if ((yrs *lt; 0) and (frac(yrs) < > 0)) then
yrs := int(yrs) - 1
else
yrs := int(yrs); days := int(yrs) + int(30.6001 * (mth + 1)) + day - 723244.0;
if days < -145068.0 then julian := days
else begin
yrs := yr / 100.0; if ((yrs < 0) and (frac(yrs) < > 0)) then
yrs := int(yrs) - 1; noleap := int(yrs); yrs := noleap / 4.0;
if ((yrs < 0) and (frac(yrs) < > 0)) then
yrs := int(yrs) - 1; leap := 2 - noleap + int(yrs); julian := days + leap;
end; end;

75. Jak mierzyć czas?


Czas wykonania pewnych operacji programista mierzy w 2 przypadkach: programista sam chce się dowiedzieć jak działa program lub poinformować użytkowników o tym. Do tego celu wykorzystujemy funkcję GetTickCount. Aby uniknąć błędu (ze względu na bardzo krótki czas 1 pomiaru i fakt, że programy pod Windows są wykonywane z różnymi prędkościami) algorytm pomiaru wykonuje zadaną operację np, 1000 razy i następnie dzieli przez 1000 aby uśrednić wynik. W przykładzie program dokładnie określa czas zmian pikseli w oknie tego programu.

procedure tform1.button1click(sender: tobject);
var i, t: integer;
begin
t := gettickcount; randomize;
for i := 0 to 100000 do
form1.canvas.pixels[i mod form1.clientwidth, i div form1.clientwidth] :=
rgb(random(255), random(255), random(255));
form1.caption := inttostr(gettickcount - t);
end;

76. Sygnalizacja (dźwięk) zmiany czasu systemowego.


...
private
procedure wmtimechange(var message: twmtimechange); message wm_timechange;
...
procedure tform1.wmtimechange(var message: twmtimechange);
begin
messgebeep(0);
end;


77. Numer tygodnia na podstawie podanego dnia w roku.


Wariant 1:
function weekofyear(adate: tdatetime): word;
var day: word; month: word; year: word; firstofyear: tdatetime;
begin
decodedate(adate,year,month,day); firstofyear:=encodedate(year,1,1);
if (adate=encodedate(year,12,31)) or
(adate=firstofyear) then result:=1 else result:=trunc(adate - firstofyear) div 7+1;
end;

Wariant 2:
function weeknum(const adate: tdatetime): word;
var year: word; month: word; day: word;
begin
decodedate(adate + 4 - dayofweek(adate + 6),year,month,day);
result:=1+trunc((adate-encodedate(year,1,5) +
dayofweek(encodedate(year,1,3))) / 7);
end;

Wariant 3:
function myweekofyear(dat: tdatetime): word;
// interpretacja numerów dni- iso: 1 = poniedziałek, 7 = niedziela
// a delphi sysutils: 1 = niedziela, 7 = sobota
var day, month, year: word; firstdate: tdatetime; datediff: integer;
begin
day:=sysutils.dayofweek(dat) - 1; dat:=dat + 3 -((6 + day) mod 7);
decodedate(dat,year,month,day); firstdate:=encodedate(year,1,1);
datediff:=trunc(dat - firstdate); result:=1 + (datediff div 7);
end;

Wariant 4:
function myweekofyear2(date: tdatetime): word;
{ a teraz standardowa funkcja z dateutils.dcu. }
begin
result:=weekof(date);
end;

Teraz sprawdzamy wszystkie opcje:
procedure tform1.button1click(sender: tobject);
begin
showmessage(inttostr(weekofyear(strtodate('31.12.2003'))));
showmessage(inttostr(weeknum(strtodate('31.12.2003'))));
showmessage(inttostr(myweekofyear(strtodate('31.12.2003'))));
showmessage(inttostr(myweekofyear2(strtodate('31.12.2003'))));
end;

78. Wykaz dysków komputera.

function driveexists(drive:byte):boolean;

function driveexists(drive:byte):boolean;
var drives: set of 0..25;
begin
integer(drives):=getlogicaldrives; result:=drive in drives
end;

function checkdrivetype(drive: byte): string;
var driveletter: char; drivetype: uint;
begin
driveletter:=chr(drive + $41); drivetype:=getdrivetype(pchar(driveletter + ':'));
case drivetype of
0: result:='?';
1: result:='ścieżka nie istnieje';
drive_removable: result:='removable'; drive_fixed: result:='fixed';
drive_remote: result:='remote'; drive_cdrom: result:='cd_rom';
drive_ramdisk: result:='ramdisk'
else
result:='nieznany' end
end;
var drives: set of 0..25;
begin
integer(drives):=getlogicaldrives; result:=drive in drives
end;

function checkdrivetype(drive: byte): string;
var driveletter: char; drivetype: uint;
begin
driveletter:=chr(drive + $41); drivetype:=getdrivetype(pchar(driveletter + ':'));
case drivetype of
0: result:='?';
1: result:='ścieżka nie istnieje';
drive_removable: result:='removable'; drive_fixed: result:='fixed';
drive_remote: result:='remote'; drive_cdrom: result:='cd_rom';
drive_ramdisk: result:='ramdisk'
else
result:='nieznany' end
end;

79. Ochrona programów Shareware


Ten mały fragment kodu pozwala na szybkie tworzenie obrony shareware, która nie wpływa na funkcjonalność programu, ale "prosi", aby zarejestrować program. Program z tym kodem (jak shareware) może być użyty tylko 1 raz; ponowne użycie - po restarcie systemu. Bazuje na obsłudze zdarzenia - w Onformshow:



procedure tform1.formshow(sender: tobject);
var atom: integer; crlf: string;
begin
if globalfindatom('this_is_some_obscuree_text') = 0 then
atom := globaladdatom('this_is_some_obscuree_text') //unikalny string w PC
else begin
crlf := #10 + #13; //zmiana linii i na początek wiersza
showmessage('Ta wersja może być użyta tylko raz '
+ 'w danym seansie Windowsa.' + crlf
+ 'dla kolejnych uruchomień'
+ crlf + 'należy program ZAREJESTROWAĆ !');
close;
end; end;

80. Zmiana czcionki dla poszczególnych komórek StringGrid

Przykład wykorzystuje zdarzenie ondrawcell i zmienia w kolumnie 2 czcionkę na Courier New.

(mygrid - tstringgrid):
procedure tform1.mygriddrawcell(sender: tobject; acol, arow: integer;
rect: trect; state: tgriddrawstate);
var oldname:string;
begin
oldname:=mygrid.canvas.font.name;
if (acol=2) then
mygrid.canvas.font.name:='courier new';
mygrid.canvas.textrect(rect, rect.left+2, rect.top+2, mygrid.cells[acol, arow]);
mygrid.canvas.font.name:=oldname;
end;