Automatické dokončování textu
    v komponentě ComboBox
Barevný přechod mezi dvěma barvami
Celoobrazovkový režim
Čas uplynutý od startu Windows
Datum velikonočních svátků
Definování horkých kláves platných pro celý
    systém
Formátování diskové jednotky
Formulář s mnohoúhelníkovým tvarem
Generování náhodného čísla z určeného
    intervalu
Hledání souborů
Inverze barev bitmapy
Kontrolní součet souboru
Konverze RGB na TColor
Kopírování a vymazání obsahu složky
Kopírování souboru se zobrazením průběhu
Kruhový formulář
Nastavení formátu horní a dolní index
    v komponentě RichEdit
Nastavení jmenovky diskety
Nastavení vizuální podoby ve stylu Windows
    XP
Odeslání emailu s přílohou pomocí Outlooku
Odstranění souborů do koše
Odstranění titulkového pruhu u formuláře
Okraje kolem textu v komponentě RichEdit
Omezení a zrušení omezení pohybu kurzoru
    myši
Ověření rodného čísla
Pouze jedna instance aplikace
Pozastavení programu
Práce s registry
Prohození tlačítek myši
Průhledný formulář
Přehrání WAVu ze souboru a zdrojů
Přemístění komponenty pomocí myši za běhu
    aplikace
Přenesení aplikace do popředí
Přesouvání formuláře pomocí klientské části
Převod barvy na HTML formát
Převod bitmapového obrázku do formátu
    JPG a naopak
Převod IP adresy na URL a naopak
Přidání souboru do seznamu naposledy
    otevřených dokumentů
Přidání vlastních položek do systémového
    menu
Přijímání událostí vyvolaných myší z jiných
    aplikací
Psaní a kreslení po pracovní ploše
Registrace vlastního typu souboru
Sériové číslo disku

Seznam místních diskových jednotek
Schování aplikace ze seznamu běžících
    procesů
Skrytí a zobrazení kurzoru myši
Skrytí a zobrazení prvků na ploše
Skrytí aplikace na hlavním panelu
Smazání vlastní aplikace
Spuštění jiné aplikace s čekáním na její
    ukončení
Spuštění jiné aplikace, souboru, složky,
    www dokumentu a odkazu na email
Startovacího logo
Stažení souboru z internetu
Stisknutí klávesy
Stisknutí tlačítka myši
Ukončení cizí aplikace
Vložení dalšího spustitelného souboru
    do aplikace
Vypnutí, odhlášení, restart počítače
    a přepnutí do režimu spánku
Vysunutí a zasunutí CD mechaniky
Vysunutí nabídky Start
Vytvoření zástupce souboru
Zachycení obsahu obrazovky
Zakázání a povolení pohybu formuláře
Zakázání a povolení překreslování okna
    aplikace
Zakázání a povolení tlačítka pro zavření
    formuláře
Zakázání a povolení Windowsovských
    kláves a kombinace CTRL+ALT+DEL
Zalomení textu tlačítka na více řádků
Zapnutí a vypnutí kláves Num Lock,
    Caps Lock a Scroll Lock
Zapnutí a vypnutí spořiče obrazovky
Získání ikony přidružené k souboru
Získání ikony ze souboru nebo knihovny
Zjištění a nastavení hlasitosti WAVů
Zjištění cesty k důležitým systémovým
    složkám
Zjištění Handle a titulku okna aktivní
    aplikace
Zjištění Handle okna jiné aplikace
Zjištění přítomnosti média v diskové
    jednotce
Zjištění stavu kláves
Zjištění umístění složky Windows a Temp
Zjištění velikosti složky včetně podsložek
Zkrácený zápis názvů složek a souborů
Změna barvy ukazatele ProgressBaru
Změna pozadí pracovní plochy
Změna rozlišení
Změna velikosti okna přehrávaného videa

Automatické dokončování textu v komponentě ComboBox

...

public
  LastKey: Word;
end;

...

procedure TForm1.ComboBox1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 LastKey:=Key;
end;

Barevný přechod mezi dvěma barvami

Function GetPigmentBetween(P1, P2, Percent: double): integer;
begin
 Result:=Round(((P2 - P1) * Percent) + P1);
  if Result > 255 then Result:=255;
  if Result < 0 then Result:=0;
end;

Function GetGradientColor(Color1, Color2: TColor; Percent: double): integer;
  var Red, Green, Blue: integer;
begin
  if Percent > 1 then Percent:=1;
  if Percent < 0 then Percent:=0;
 Red:=GetPigmentBetween(GetRValue(Color1), GetRValue(Color2), Percent);
 Green:=GetPigmentBetween(GetGValue(Color1), GetGValue(Color2), Percent);
 Blue:=GetPigmentBetween(GetBValue(Color1), GetBValue(Color2), Percent);
 Result:=Red + Green * 256 + Blue * 65536;
end;

procedure TForm1.Button1Click(Sender: TObject);
  var Color: TColor;
begin
 Color:=GetGradientColor(clRed, clBlue, 0.5);
end;

Celoobrazovkový režim

procedure TForm1.FormCreate(Sender: TObject);
  var HTaskBar: HWnd;
        OldVal: LongInt;
begin
 try
  HTaskBar:=FindWindow('Shell_TrayWnd', nil);
  SystemParametersInfo(97, Word(True), @OldVal, 0) ;
  EnableWindow(HTaskBar, False);
  ShowWindow(HTaskBar, SW_HIDE);
 finally
  BorderStyle:=bsNone;
  FormStyle:=fsStayOnTop;
  Left:=0;
  Top:=0;
  Height:=Screen.Height;
  Width:=Screen.Width;
 end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
    var HTaskBar: HWnd;
          OldVal: LongInt;
begin
 HTaskBar:=FindWindow('Shell_TrayWnd', nil);
 SystemParametersInfo(97, Word(False), @OldVal, 0);
 EnableWindow(HTaskBar, True);
 ShowWindow(HTaskbar, SW_SHOW);
end;

Čas uplynutý od startu Windows

ShowMessage(IntToStr(GetTickCount) + ' milisekund'); // nebo

procedure TForm1.Button1Click(Sender: TObject);
  var DT: TDateTime;
begin
 DT:=TimeStampToDateTime(MSecsToTimeStamp(GetTickCount));
 ShowMessage(FormatDateTime('hh:nn:ss', DT));
end;

Datum velikonočních svátků

Function Velikonoce(Rok: integer): TDateTime;
  var R1, R2, R3, X, Y, Z: double;
        Tmp: integer;
begin
 R1:=Rok mod 19;
 R2:=Rok mod 4;
 R3:=Rok mod 7;
 X:=19 * R1 + 24;
 Y:=X - (Int(X / 30) * 30);
 Z:=(5 + 2 * R2 + 4 * R3 + 6 * Y);
 Tmp:=Trunc((Z - (Int(Z / 7) * 7)) + Y + 22);
  if Tmp <= 31 then Result:=EncodeDate(Rok, 3, Tmp)
   else
    begin
      if Tmp - 31 >= 26 then Tmp:=19
       else Dec(Tmp, 31);
     Result:=EncodeDate(Rok, 4, Tmp);
    end;
end;

Definování horkých kláves platných pro celý systém

const HotKeyID = 1;

...

Do sekce public přidejte: Procedure WMHotKey(var Msg: TWMHotKey); message WM_HotKey;

A za implementation umístěte následující proceduru:

Procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
 if Msg.HotKey=HotKeyID then
  begin
   SendMessage(Application.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
   SetForegroundWindow(Application.Handle);
   Msg.Result:=0;
  end
 else
  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Win32Check(RegisterHotKey(Handle, HotKeyID, MOD_CONTROL or MOD_SHIFT, Ord('T')));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 UnregisterHotKey(Handle, HotKeyID);
end;

Formátování diskové jednotky

const SHFMT_DRV_A = 0;
          SHFMT_DRV_B = 1;
          SHFMT_ID_DEFAULT = $FFFF;
          SHFMT_OPT_QUICKFORMAT = 1;
          SHFMT_OPT_FULLFORMAT = 0;
          SHFMT_OPT_SYSONLY = 2;
          SHFMT_ERROR = -1;
          SHFMT_CANCEL = -2;
          SHFMT_NOFORMAT = -3;

...

Function SHFormatDrive(HWnd: HWnd; Drive: Word; FmtID: Word; Options: Word): longint stdcall;
 external 'Shell32.dll' name 'SHFormatDrive';

procedure TForm1.Button1Click(Sender: TObject);
  var FmtRes: longint;
begin
 try
  FmtRes:=SHFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
   case FmtRes of
    SHFMT_ERROR: ShowMessage('Při formátování disku došlo k chybě.');
    SHFMT_CANCEL: ShowMessage('Formátování disku bylo zrušeno.');
    SHFMT_NOFORMAT: ShowMessage('Disk nebyl zformátován.');
   else
    ShowMessage('Disk byl úspěšně zformátován.');
   end;
 except
 end;
end;

Formulář s mnohoúhelníkovým tvarem

procedure TForm1.FormCreate(Sender: TObject);
  var Rgn: HRgn;
        Points: array[0..7] of TPoint;
begin
 Points[0]:=Point(0, 0);
 Points[1]:=Point(100, 0);
 Points[2]:=Point(250, 200);
 Points[3]:=Point(400, 0);
 Points[4]:=Point(500, 0);
 Points[5]:=Point(500, 300);
 Points[6]:=Point(0, 300);
 Points[7]:=Point(0, 0);
 Rgn:=CreatePolygonRgn(Points, 8, ALTERNATE);
 SetWindowRgn(Handle, Rgn, True);
end;

Generování náhodného čísla z určeného intervalu

Function RandomInt(Min, Max: integer): integer;
begin
 Result:=Min + Random(Max - Min + 1);
end;

Hledání souborů

uses Imagehlp;

Function FileSearch(RootDir, FileName: string): string;
  var Path: array[0..MAX_PATH] of Char;
begin
 if SearchTreeForFile(PChar(RootDir), PChar(FileName), Path) then Result:=Path
  else Result:='';
end;

Inverze barev bitmapy

procedure TForm1.Button1Click(Sender: TObject);
  var Rct: TRect;
begin
 with Image1.Picture.Bitmap do
  begin
   Rct:=Rect(0, 0, Width, Height);
   InvertRect(Canvas.Handle, Rct);
  end;
 Image1.Invalidate;
end;

Kontrolní součet souboru

1. způsob

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(IntToStr(GetCheckSum('C:\Aplikace.exe')));
end;

2. způsob - CRC 32

const Table: array[0..255] of DWord =
      ($00000000, $77073096, $EE0E612C, $990951BA,
      $076DC419, $706AF48F, $E963A535, $9E6495A3,
      $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
      $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
      $1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
      $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
      $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
      $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
      $3B6E20C8, $4C69105E, $D56041E4, $A2677172,
      $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
      $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
      $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
      $26D930AC, $51DE003A, $C8D75180, $BFD06116,
      $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
      $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
      $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
      $76DC4190, $01DB7106, $98D220BC, $EFD5102A,
      $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
      $7807C9A2, $0F00F934, $9609A88E, $E10E9818,
      $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
      $6B6B51F4, $1C6C6162, $856530D8, $F262004E,
      $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
      $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
      $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
      $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
      $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
      $4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
      $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
      $5005713C, $270241AA, $BE0B1010, $C90C2086,
      $5768B525, $206F85B3, $B966D409, $CE61E49F,
      $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
      $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
      $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
      $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
      $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
      $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
      $F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
      $F762575D, $806567CB, $196C3671, $6E6B06E7,
      $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
      $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
      $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
      $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
      $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
      $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
      $CB61B38C, $BC66831A, $256FD2A0, $5268E236,
      $CC0C7795, $BB0B4703, $220216B9, $5505262F,
      $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
      $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
      $9B64C2B0, $EC63F226, $756AA39C, $026D930A,
      $9C0906A9, $EB0E363F, $72076785, $05005713,
      $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
      $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
      $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
      $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
      $88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
      $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
      $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
      $A7672661, $D06016F7, $4969474D, $3E6E77DB,
      $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
      $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
      $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
      $BAD03605, $CDD70693, $54DE5729, $23D967BF,
      $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
      $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);

...

Procedure CalcCRC32(FileName: string; var CRC32: DWord);
  var F: file;
        BytesRead: DWord;
        Buffer: array[1..65521] of byte;
        i: Word;
begin
 FileMode:=0;
 CRC32:=$ffffffff;
 {$I-}
 AssignFile(F, FileName);
 Reset(F, 1);
  if IOResult = 0 then
   begin
    repeat
     BlockRead(F, Buffer, SizeOf(Buffer), BytesRead);
      for i :=1 to BytesRead do CRC32:= (CRC32 shr 8) xor Table[Buffer[i] xor (CRC32 and $000000FF)];
    until BytesRead = 0;
   end;
 CloseFile(F);
 {$I+}
 CRC32:= not CRC32;
end;

procedure TForm1.Button1Click(Sender: TObject);
  var CRC: DWord;
begin
 CalcCRC32('C:\Aplikace.exe', CRC);
  if CRC <> 0 then ShowMessage(IntToHex(CRC, 6));
end;

Konverze RGB na TColor

Function RGBToColor(Red, Green, Blue: integer): integer;
begin
 Result:=Red + Green * 256 + Blue * 65536;
end;

Kopírování a vymazání obsahu složky

Kopírování

uses ShellApi;

Function CopyDirContent(SourceDir, Mask, TargetDir: string): boolean;
  var FileOp: TSHFileOpStruct;
begin
 ZeroMemory(@FileOp, SizeOf(FileOp));
  if SourceDir[Length(SourceDir)] <> '\' then SourceDir:=SourceDir + '\';
  with FileOp do
   begin
    Wnd:=Form1.Handle;
    wFunc:=FO_COPY;
    pFrom:=PChar(SourceDir + Mask);
    pTo:=PChar(TargetDir);
    fFlags:=FOF_ALLOWUNDO or FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR;
   end;
  if (SHFileOperation(FileOp) <> 0) or (FileOp.fAnyOperationsAborted) then Result:=False
   else Result:=True;
end;

Vymazání

uses ShellApi;

Function DeleteDirContent(Dir, Mask: string): boolean;
  var FileOp: TSHFileOpStruct;
begin
 ZeroMemory(@FileOp, SizeOf(FileOp));
  if Dir[Length(Dir)] <> '\' then Dir:=Dir + '\';
  with FileOp do
   begin
    Wnd:=Form1.Handle;
    wFunc:=FO_DELETE;
    pFrom:=PChar(Dir + Mask);
    fFlags:=FOF_ALLOWUNDO or FOF_SILENT or FOF_NOCONFIRMATION;
   end;
  if (SHFileOperation(FileOp) <> 0) or (FileOp.fAnyOperationsAborted) then Result:=False
   else Result:=True;
end;

Kopírování souboru se zobrazením průběhu

Procedure CopyFileWithProgressBar(SourceFile, TargetFile: string);
  var FromFile, ToFile: file of byte;
        Buffer: array[0..4096] of Char;
        NumRead: integer;
        FileLength: longint;
begin
 AssignFile(FromFile, SourceFile);
 Reset(FromFile);
 AssignFile(ToFile, TargetFile);
 Rewrite(ToFile);
 FileLength:=FileSize(FromFile);
  with Form1.Progressbar1 do
   begin
    Min:=0;
    Max:=FileLength;
     while FileLength > 0 do
      begin
       BlockRead(FromFile, Buffer[0], SizeOf(Buffer), NumRead);
       FileLength:=FileLength - NumRead;
       BlockWrite(ToFile, Buffer[0], NumRead);
       Position:=Position + NumRead;
       Application.ProcessMessages;
      end;
    CloseFile(FromFile);
    CloseFile(ToFile);
   end;
end;

Kruhový formulář

procedure TForm1.FormCreate(Sender: TObject);
  var Rgn: HRgn;
begin
 Rgn:=CreateEllipticRgn(0, 0, Width, Height);
 SetWindowRgn(Handle, Rgn, True);
end;

Nastavení formátu horní a dolní index v komponentě RichEdit

Horní index

uses RichEdit;

procedure TForm1.Button1Click(Sender: TObject);
  var Format: TCharFormat;
begin
 FillChar(Format, SizeOf(Format), 0);
  with Format do
   begin
    cbSize:=SizeOf(Format);
    dwMask:=CFM_OFFSET;
    yOffset:= 60;
   end;
 RichEdit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;

Dolní index

uses RichEdit;

procedure TForm1.Button1Click(Sender: TObject);
  var Format: TCharFormat;
begin
 FillChar(Format, SizeOf(Format), 0);
  with Format do
   begin
    cbSize:=SizeOf(Format);
    dwMask:=CFM_OFFSET;
    yOffset:= -60;
   end;
 RichEdit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;

Nastavení jmenovky diskety

Win32Check(SetVolumeLabel('A:\', 'Moje disketa'));

Nastavení vizuální podoby ve stylu Windows XP

Nejprve vytvoříme soubor (např. v poznámkovém bloku) xp.manifest s tímto obsahem:

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
       name="CompanyName.ProductName.YourApplication"
       processorArchitecture="x86"
       version="1.0.0.0"
       type="win32"/>
<description>Windows Shell</description>
<dependency>
        <dependentAssembly>
                <assemblyIdentity
                       type="win32"
                       name="Microsoft.Windows.Common-Controls"
                       version="6.0.0.0"
                       processorArchitecture="x86"
                       publicKeyToken="6595b64144ccf1df"
                       language="*"
                />
        </dependentAssembly>
</dependency>
</assembly>

Nyní vytvoříme soubor xp.rc s tímto obsahem:

1 24 "xp.manifest"

Poté tento soubor zkompilujeme z příkazového řádku pomocí programu Resources Compiler, který je součástí Delphi (Delphi/Bin/brcc32.exe):

C:\Program Files\Borland\Delphi\Bin\brcc32.exe xp.rc

Nyní se nám vytvoří zkompilovaný resource soubor xp.res, který už jen stačí přidat do zdrojového kódu formuláře:

{$R XP.RES}

Např.

...

  private
    { Private declarations }
  public
    {Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
{$R XP.RES}

...

Odeslání emailu s přílohou pomocí Outlooku

uses ComObj;

procedure TForm1.Button1Click(Sender: TObject);
  const olMailItem = 0;
  var Outlook: OleVariant;
        MailItem: Variant;
begin
  try
   Outlook:=GetActiveOleObject('Outlook.Application');
  except
   Outlook:=CreateOleObject('Outlook.Application');
  end;
 MailItem:=Outlook.CreateItem(olMailItem);
 MailItem.Recipients.Add('Adresa@Seznam.cz');
 MailItem.Subject:='Předmět';
 MailItem.Body:='Zpráva';
 MailItem.Attachments.Add('C:\Příloha.zip');
 MailItem.Send;
 Outlook:=Unassigned;
end;

Odstranění souborů do koše

uses ShellApi;

Function DeleteToRecycleBin(const FileName: string): boolean;
  var FileOp: TSHFileOpStruct;
begin
  if Integer(GetFileAttributes(PChar(FileName))) <> -1 then
   begin
    ZeroMemory(@FileOp, SizeOf(FileOp));
     with FileOp do
      begin
       wFunc:=FO_DELETE;
       pFrom:=PChar(FileName);
       fFlags:=FOF_ALLOWUNDO or FOF_SILENT or FOF_NOCONFIRMATION;
       Result:=(SHFileOperation(FileOp) = 0);
      end;
   end
  else
   Result:=False;
end;

Odstranění titulkového pruhu u formuláře

Do sekce public přidejte: Procedure CreateParams(var Params: TCreateParams); override;

A za implementation umístěte následující proceduru:

Procedure TForm1.CreateParams(var Params: TCreateParams);
begin
 inherited CreateParams(Params);
  with Params do Style:=(Style or WS_POPUP) and (not WS_DLGFRAME);
end;

Okraje kolem textu v komponentě RichEdit

uses RichEdit;

procedure TForm1.Button1Click(Sender: TObject);
  var Rct: TRect;
begin
 RichEdit1.Perform(EM_GETRECT, 0, lparam(@Rct));
 InflateRect(Rct, -20, -20);
 RichEdit1.Perform(EM_SETRECT, 0, lparam(@Rct));
end;

Omezení a zrušení omezení pohybu kurzoru myši

Omezení pohybu

Procedure LockCursorArea(Left, Top, Right, Bottom: integer);
  var Area: PRect;
begin
 GetMem(Area, SizeOf(TRect));
 FillChar(Area^, SizeOf(TRect), #0);
 Area.Left:=Left;
 Area.Top:=Top;
 Area.Right:=Right;
 Area.Bottom:=Bottom;
 ClipCursor(Area);
end;

Zrušení omezení pohybu

Procedure UnLockCursorArea;
  var Area: PRect;
begin
 Area:=nil;
 ClipCursor(Area);
end;

Ověření rodného čísla

Function VerifyNativeNumber(RodneCislo: string): boolean;
  var RC: integer;
begin
 Result:=False;
  if StrToInt(Copy(RodneCislo, 1, 2)) < 54 then exit;
 RC:=StrToInt(Copy(RodneCislo, 1, 2)) +
         StrToInt(Copy(RodneCislo, 3, 2)) +
         StrToInt(Copy(RodneCislo, 5, 2)) +
         StrToInt(Copy(RodneCislo, 8, 4));
  if (RC mod 11) = 0 then Result:=True;
end;

Pouze jedna instance aplikace

program Project1;

uses
  Forms, Windows, Messages,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

var Wnd: HWnd;

begin
 Wnd:=FindWindow('TForm1', nil);
  if Wnd = 0 then
   begin
    Application.Initialize;
    Application.CreateForm(TForm1, Form1);
    Application.Run;
   end
  else
   begin
    if not IsWindowVisible(Wnd) then
     PostMessage(Wnd, WM_USER, 0, 0);
    SetForegroundWindow(Wnd);
   end;
end.

Pozastavení programu

Sleep(5000); // v milisekundách

Procedure Delay(MSec: integer);
  var Konec: integer;
begin
 Konec:=GetTickCount + MSec;
  while GetTickCount < Konec do Application.ProcessMessages;
end;

Práce s registry

Čtení z registru

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
  var Reg: TRegistry;
        Info: TRegKeyInfo;
begin
 with Reg do
  begin
   Reg:=TRegistry.Create;
   RootKey:=HKEY_LOCAL_MACHINE;
   OpenKey('Software\Pokus', True);
   ShowMessage(ReadString('Položka'));
    if GetKeyInfo(Info) then
     ShowMessage(IntToStr(Info.NumValues));
   CloseKey;
   Free;
  end;
end;

Zápis do registru

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
  var Reg: TRegistry;
begin
 with Reg do
  begin
   Reg:=TRegistry.Create;
   RootKey:=HKEY_LOCAL_MACHINE;
   OpenKey('Software\Pokus', True);
   WriteString('Položka', 'obsah položky');
   CloseKey;
   Free;
  end;
end;

Prohození tlačítek myši

SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 1, nil, 0); // prohození tlačítek
SystemParametersInfo(SPI_SETMOUSEBUTTONSWAP, 0, nil, 0); // vrácení zpátky

Průhledný formulář

...

public
  Procedure SetFormVisibility(Visible: boolean);
end;

...

Procedure TForm1.SetFormVisibility;
  var Control: TControl;
        Margin, X, Y, CtrlX, CtrlY, i: integer;
        FullRgn, ClientRgn, CtrlRgn: THandle;
begin
  if Visible then
   begin
    FullRgn:=CreateRectRgn(0, 0, Width, Height);
    CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);
   end
  else
   begin
    Margin:=(Width - ClientWidth) div 2;
    FullRgn:=CreateRectRgn(0, 0, Width, Height);
    X:=Margin;
    Y:=Height - ClientHeight - Margin;
    ClientRgn:=CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight);
    CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);
     for i:= 0 to ControlCount - 1 do
      begin
       Control:=Controls[i];
        if (Control is TWinControl) or (Control is TGraphicControl) then
         with Control do
          if Visible then
           begin
            CtrlX:=X + Left;
            CtrlY:=Y + Top;
            CtrlRgn:=CreateRectRgn(CtrlX, CtrlY, CtrlX + Width, CtrlY + Height);
            CombineRgn(FullRgn, FullRgn, CtrlRgn, RGN_OR);
           end;
      end;
   end;
 SetWindowRgn(Handle, FullRgn, True);
end;

Přehrání WAVu ze souboru a zdrojů

Ze souboru

uses MMSystem;

PlaySound(PChar('C:\Zvuk.wav'), 0, SND_FILENAME or SND_ASYNC); // nebo
sndPlaySound('C:\Zvuk.wav', SND_FILENAME or SND_SYNC);

Ze zdrojů

Definice v souboru zdrojů musí obsahovat text: Zvuk WAVE C:\Zvuk.wav

uses MMSystem;

PlaySound('Zvuk', HInstance, SND_RESOURCE or SND_SYNC);

Přemístění komponenty pomocí myši za běhu aplikace

const CM_MOV: integer = 61457; // nebo $F012

...

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 ReleaseCapture;
 Panel1.Perform(WM_SYSCOMMAND, CM_MOV, 0);
end;

Přenesení aplikace do popředí

SetForegroundWindow(Application.Handle);

Přesouvání formuláře pomocí klientské části

1. způsob

Do sekce public přidejte: Procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHitTest;

A za implementation umístěte následující proceduru:

Procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
 inherited;
  if Msg.Result = htClient then Msg.Result:=htCaption;
end;

2. způsob

Do sekce public přidejte:

Procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;

A za implementation umístěte následující proceduru:

Procedure TForm1.WMLButtonDown(var Msg: TWMLButtonDown);
begin
 if WindowState = wsNormal then
  begin
   ReleaseCapture;
   SendMessage(Handle,WM_SYSCOMMAND, SC_MOVE + 1, 0);
  end;
end;

Převod barvy na HTML formát

Function ColorToHtml(Color: TColor): string;
  var RGB: TColorRef;
begin
 RGB:=ColorToRGB(Color);
 Result:=Format('#%.2x%.2x%.2x', [GetRValue(RGB), GetGValue(RGB), GetBValue(RGB)]);
end;

Převod bitmapového obrázku do formátu JPG a naopak

BMP do JPG

uses Jpeg;

Procedure BmpToJpg(BmpFile, JpgFile: string; Quality: integer);
  var Bmp: TBitmap;
        Jpg: TJPEGImage;
begin
 Bmp:=TBitmap.Create;
 Jpg:=TJPEGImage.Create;
 Bmp.LoadFromFile(BmpFile);
 Jpg.CompressionQuality:=Quality;
 Jpg.Assign(Bmp);
 Jpg.SaveToFile(JpgFile);
 Jpg.Free;
 Bmp.Free;
end;

JPG do BMP

uses Jpeg;

Procedure JpgToBmp(JpgFile, BmpFile: string);
  var Jpg: TJPEGImage;
        Bmp: TBitmap;
begin
 Jpg:=TJPEGImage.Create;
 Bmp:=TBitmap.Create;
 Jpg.LoadFromFile(JpgFile);
 Bmp.Width:=Jpg.Width;
 Bmp.Height:=Jpg.Height;
 Bmp.Canvas.Draw(0, 0, Jpg);
 Bmp.SaveToFile(BmpFile);
 Bmp.Free;
 Jpg.Free;
end;

Převod IP adresy na URL a naopak

Převod IP adresy na URL

uses WinSock;

Function IpAddressToHostName(const IP: string): string;
  var I: integer;
        P: PHostEnt;
        WSAData: TWSAData;
begin
 Result:='';
  if WSAStartup($101, WSAData) = 0 then
   begin
    I:=inet_addr(PChar(IP));
     if I <> u_long(INADDR_NONE) then
      begin
       P:=GetHostByAddr(@I, SizeOf(Integer), PF_INET);
        if P <> nil then Result:=P^.h_name;
      end
     else
      Result:='Invalid IP address';
    WSACleanup;
   end;
end;

Převod URL na IP adresu

uses WinSock;

Function HostNameToIpAddress(const Host: string): string;
  var I: TInAddr;
        P: PHostEnt;
        WSAData: TWSAData;
begin
 I.S_addr:=0;
 WSAStartup(MakeWord(1, 1), WSAData);
 P:=GetHostByName(PChar(Host));
  if P <> nil then
   with I.S_un_b, P^ do
    begin
     s_b1:=h_addr_list^[0];
     s_b2:=h_addr_list^[1];
     s_b3:=h_addr_list^[2];
     s_b4:=h_addr_list^[3];
    end;
 Result:=inet_ntoa(I);
 WSACleanup;
end;

Přidání souboru do seznamu naposledy otevřených dokumentů

uses ShellApi, ShlObj;

SHAddToRecentDocs(SHARD_PATH, PChar('C:\Dokument.txt'));

Přidání vlastních položek do systémového menu

const Info = 100;
         TrayIcon = 101;

...

public
  Menu: HMenu;
  Procedure WMSysCommand(var Msg: TMessage); message WM_SYSCOMMAND;
end;

...

Procedure TForm1.WMSysCommand(var Msg: TMessage);
begin
  if Msg.WParam = Info then ShowMessage('Kliknuto na položku Info.');
  if Msg.WParam = TrayIcon then ShowMessage('Kliknuto na položku Minimalizovat do hlavního panelu.');
 inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Menu:=GetSystemMenu(Handle, False);
 AppendMenu(Menu, MF_SEPARATOR, 0, '');
 AppendMenu(Menu, MF_STRING, Info, '&Info');
 AppendMenu(Menu, MF_STRING, TrayIcon, 'Minimalizovat do &hlavního panelu');
end;

Přijímání událostí vyvolaných myší z jiných aplikací

SetCapture(Handle); // nastavení přijímání
ReleaseCapture;       // zrušení přijímání

Psaní a kreslení po pracovní ploše

Psaní

Function SetFont(Size, Angle, FontWeight: integer; Italic, Underline, Strikeout: boolean; FontName: PChar): integer;
begin
 Result:=CreateFont(Size, 0, Angle*10, 0, FontWeight, Ord(Italic), Ord(Underline), Ord(Strikeout), DEFAULT_CHARSET,
  OUT_TT_PRECIS, $10, 2, 4, FontName);
end;

Procedure WriteOnDesktop(X, Y: integer; Text: string; Barva: TColor; Font: integer);
  var DC: HDC;
begin
 DC:=GetWindowDC(GetDesktopWindow);
  try
   SetTextColor(DC, Barva);
   SetBkMode(DC, TRANSPARENT);
   SelectObject(DC, Font);
   TextOut(DC, X, Y, PChar(Text), Length(Text));
  finally
   ReleaseDC(GetDesktopWindow, DC);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
  var Font: integer;
begin
 Font:=SetFont(36, 0, FW_NORMAL, False, False, False, 'Times New Roman');
 WriteOnDesktop(200, 200, 'Ahoj', clBlue, Font);
end;

Kreslení

procedure TForm1.Button1Click(Sender: TObject);
  var DC: HDC;
        LogBrush: tagLOGBRUSH;
        Brush: HBrush;
        Pen: HPen;
begin
 DC:=GetWindowDC(GetDesktopWindow);
  try
   with LogBrush do
    begin
     lbStyle:=BS_SOLID;
     lbColor:=clRed;
     lbHatch:=BS_SOLID;
    end;
   Brush:=CreateBrushIndirect(LogBrush);
   Pen:=CreatePen(PS_SOLID, 1, clBlue);
   SelectObject(DC, Brush);
   SelectObject(DC, Pen);
   Rectangle(DC, 250, 250, 450, 350); // zde můžou být použity i jiné metody kreslení
  finally
   ReleaseDC(GetDesktopWindow, DC);
  end;
end;

Registrace vlastního typu souboru

Registrace

uses ShlObj, Registry;

Function RegFileType(Extension, AppName, Description, IconPath: string; IconIndex: integer): boolean;
  var Reg: TRegistry;
        Path: string;
begin
 Result:=False;
 Path:=Extension + 'file';
  with Reg do
   begin
    Reg:=TRegistry.Create;
     try
      RootKey:=HKEY_CLASSES_ROOT;
       if OpenKey('.' + Extension, True) then
        begin
         WriteString('', Path);
         CloseKey;
        end;
       if OpenKey(Path, True) then
        begin
         WriteString('', Description);
         CloseKey;
        end;
       if OpenKey(Path + '\DefaultIcon', True) then
        begin
         WriteString('', IconPath + ', ' + IntToStr(IconIndex));
         CloseKey;
        end;
       if OpenKey(Path + '\Shell\Open\Command', True) then
        begin
         WriteString('', AppName + ' %1');
         CloseKey;
        end;
       if OpenKey(Path + '\Shell', False) then
        begin
         WriteString('', 'Open');
         CloseKey;
         Result:=True;
        end;
      SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
     finally
      Free;
     end;
   end;
end;

Odregistrace

uses Registry;

Function UnRegFileType(Extension: string): boolean;
  var Reg: TRegistry;
begin
 Result:=False;
  with Reg do
   begin
    Reg:=TRegistry.Create;
     try
      RootKey:=HKEY_CLASSES_ROOT;
      DeleteKey('.' + Extension);
      DeleteKey(Extension + 'file');
      Result:=True;
     finally
      Free;
     end;
   end;
end;

Sériové číslo disku

Function SerialNumberStr(const Path: string): string;
  var SN, MCL, FSF: DWord;
begin
  if GetVolumeInformation(PChar(Path), nil, 0, @SN, MCL, FSF, nil, 0) then
   Result:=Format('%x-%x', [LongRec(SN).Hi, LongRec(SN).Lo])
  else
   Result:='';
end;

Seznam místních diskových jednotek

procedure TForm1.Button1Click(Sender: TObject);
  var Drives: set of 0..25;
        D: Char;
begin
 DWord(Drives):=GetLogicalDrives;
  for D:='A' to 'Z' do
   if (Ord(D) - Ord('A')) in Drives then
    ListBox1.Items.Add(D);
end;

Schování aplikace ze seznamu běžících procesů

Function RegisterServiceProcess(dwProcessID, dwType: integer): integer; stdcall; external 'Kernel32.dll';

RegisterServiceProcess(GetCurrentProcessID, 1); // schová aplikaci
RegisterServiceProcess(GetCurrentProcessID, 0); // zobrazí aplikaci

Skrytí a zobrazení kurzoru myši

ShowCursor(False); // skryje kurzor myši
ShowCursor(True);  // zobrazí kurzor myši

Skrytí a zobrazení prvků na ploše

Skrytí a zobrazení hlavního panelu

Procedure HideTrayBar(Hide: boolean);
  var Wnd: THandle;
begin
 Wnd:=FindWindow('Shell_TrayWnd', nil);
   if Hide then
    ShowWindow(Wnd, SW_HIDE)
   else
    ShowWindow(Wnd, SW_SHOW);
end;

Skrytí a zobrazení oznamovací oblasti

Procedure HideTrayNotify(Hide: boolean);
  var Wnd: THandle;
begin
 Wnd:=FindWindow('Shell_TrayWnd', nil);
 Wnd:=FindWindowEx(Wnd, HWnd(0), 'TrayNotifyWnd', nil);
   if Hide then
    ShowWindow(Wnd, SW_HIDE)
   else
    ShowWindow(Wnd, SW_SHOW);
end;

Skrytí a zobrazení tlačítka Start

Procedure HideStartButton(Hide: boolean);
  var Wnd: THandle;
begin
 Wnd:=FindWindow('Shell_TrayWnd', nil);
 Wnd:=FindWindowEx(Wnd, HWnd(0), 'Button', nil);
   if Hide then
    ShowWindow(Wnd, SW_HIDE)
   else
    ShowWindow(Wnd, SW_SHOW);
end;

Skrytí a zobrazení přepínače úloh

Procedure HideAppSwitchBar(Hide: boolean);
  var Wnd: THandle;
begin
 Wnd:=FindWindow('Shell_TrayWnd', nil);
 Wnd:=FindWindowEx(Wnd, HWnd(0), 'ReBarWindow32', nil);
   if Hide then
    ShowWindow(Wnd, SW_HIDE)
   else
    ShowWindow(Wnd, SW_SHOW);
end;

Skrytí a zobrazení hodin

Procedure HideTrayClock(Hide: boolean);
  var Wnd: THandle;
begin
 Wnd:=FindWindow('Shell_TrayWnd', nil);
 Wnd:=FindWindowEx(Wnd, HWnd(0), 'TrayNotifyWnd', nil);
 Wnd:=FindWindowEx(Wnd, HWnd(0), 'TrayClockWClass', nil);
   if Hide then
    ShowWindow(Wnd, SW_HIDE)
   else
    ShowWindow(Wnd, SW_SHOW);
end;

Skrytí a zobrazení ikon

Procedure HideDesktopIcons(Hide: boolean);
  var Wnd: THandle;
begin
 Wnd:=FindWindow('Progman', nil);
 Wnd:=FindWindowEx(Wnd, HWnd(0), 'ShellDll_DefView', nil);
   if Hide then
    ShowWindow(Wnd, SW_HIDE)
   else
    ShowWindow(Wnd, SW_SHOW);
end;

Skrytí aplikace na hlavním panelu

ShowWindow(Application.Handle, SW_HIDE);    // skryje aplikaci
ShowWindow(Application.Handle, SW_SHOW); // zobrazí aplikaci

Smazání vlastní aplikace

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
  var Reg: TRegistry;
begin
 with Reg do
  begin
   Reg:=TRegistry.Create;
   RootKey:=HKEY_LOCAL_MACHINE;
   OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', False);
   WriteString(Application.Title, 'command.com /C del ' + Application.ExeName);
   CloseKey;
   Free;
  end;
end;

Spuštění jiné aplikace s čekáním na její ukončení

Function WinExecAndWait(FileName: string; Visibility: integer): integer;
  var StartupInfo: TStartupInfo;
        ProcessInfo: TProcessInformation;
begin
 FillChar(StartupInfo, SizeOf(StartupInfo), #0);
 StartupInfo.cb:=SizeOf(StartupInfo);
 StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;
 StartupInfo.wShowWindow:=Visibility;
  if not CreateProcess(nil, PChar(FileName), nil,nil, False, NORMAL_PRIORITY_CLASS, nil,nil, StartupInfo, ProcessInfo)
   then Result:= -1
 else
  begin
    repeat
     Application.ProcessMessages;
    until WaitForSingleObject(ProcessInfo.hProcess, 1) = WAIT_OBJECT_0;
   GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 WinExecAndWait('notepad.exe', SW_SHOWNORMAL);
 ShowMessage('Aplikace byla ukončena.');
end;

Spuštění jiné aplikace, souboru, složky, www dokumentu a odkazu na email

uses ShellApi;

Spuštění jiné aplikace

ShellExecute(Handle, 'open', PChar('C:\Aplikace.exe'), nil, nil, SW_SHOWNORMAL); // nebo
WinExec(PChar('C:\Aplikace.exe'), SW_SHOWNORMAL);

Spuštění souboru

ShellExecute(Handle, 'open', PChar('C:\Dokument.txt'), nil, nil, SW_SHOWNORMAL);

Otevření složky

ShellExecute(Handle, 'open', 'C:\', nil, nil, SW_SHOWNORMAL);     // otevře složku
ShellExecute(Handle, 'explore', 'C:\', nil, nil, SW_SHOWNORMAL); // zobrazí složku v průzkumníku

Spuštění www dokumentu

ShellExecute(Handle, 'open', PChar('C:\Dokument.htm'), nil, nil, SW_SHOWNORMAL); 
ShellExecute(Handle, 'open', PChar('www.seznam.cz'), nil, nil, SW_SHOWNORMAL); 

Odkaz na email

ShellExecute(Handle, 'open', PChar('mailto:Adresa@Seznam.cz'), nil, nil, SW_SHOWNORMAL); // nebo

procedure TForm1.Button1Click(Sender: TObject);
  var Mail: string;
begin
 Mail:='mailto:Adresa@Seznam.cz?Subject=Předmět&Cc=Odesilatel@Seznam.cz&Body=Zpráva';
 ShellExecute(Handle, 'open', PChar(Mail), nil, nil, SW_SHOWNORMAL);
end;

Startovací logo

Nejprve vytvoříme startovací formulář, nazveme jej Logo a nastavíme, aby se nevytvářel automaticky
(v Project Options přesuneme náš formulář ze seznamu Auto-create forms do Available forms).

program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas' {Logo};

{$R *.RES}

begin
 Logo:= TLogo.Create(nil);
 Logo.Show;
 Application.ProcessMessages; 

 {sem přijde váš kód - například načítání nastavení}

 Application.Initialize;
 Application.CreateForm(TForm1, Form1);
 Logo.Hide;
 Logo.Release;
 Application.Run;
end.

Stažení souboru z internetu

uses UrlMon;

Function DownloadFile(RemoteFile, LocalFile: string): boolean;
begin
 if URLDownloadToFile(nil, PChar(RemoteFile), PChar(LocalFile), 0, nil) = 0 then
  Result:=True
 else
  Result:=False;
end;

Stisknutí klávesy

keybd_event(Ord('M'), MapVirtualKey(Ord('M'), 0), 0, 0);                                     // stisknutí klávesy
keybd_event(Ord('M'), MapVirtualKey(Ord('M'), 0), KEYEVENTF_KEYUP, 0); // uvolnění klávesy
// nebo
keybd_event(Ord('M'), MapVirtualKey(Ord('M'), 0), KEYEVENTF_EXTENDEDKEY, 0);

Stisknutí tlačítka myši

mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0); // stisknutí tlačítka
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);        // puštění tlačítka

Ukončení cizí aplikace

PostMessage(FindWindow(nil, 'titulek'), WM_QUIT, 0, 0);

Vložení dalšího spustitelného souboru do aplikace

Nejprve vytvoříme v poznámkovém bloku soubor kalkulacka.rc s tímto obsahem:

Kalkulačka EXEFILE C:\Windows\System32\Calc.exe

Poté tento soubor zkompilujeme z příkazového řádku pomocí programu Resources Compiler, který je součástí Delphi (Delphi/Bin/brcc32.exe):

C:\Program Files\Borland\Delphi\Bin\brcc32.exe kalkulacka.rc

Nyní se nám vytvoří zkompilovaný resource soubor kalkulacka.res, který přidáme do zdrojového kódu formuláře.

uses ShellApi;

...

var
  Form1: TForm1;

implementation

{$R *.DFM}
{$R KALKULACKA.RES}

...

Procedure ExtractResource(ResourceType, ResourceName, FileName: string);
  var Resource: TResourceStream;
begin
 Resource:=TResourceStream.Create(HInstance, ResourceName, PChar(ResourceType));
  try
   Resource.SaveToFile(FileName);
  finally
   Resource.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 ExtractResource('EXEFILE', 'Kalkulačka', 'C:\Calc.exe');
end;

Vypnutí, odhlášení, restart počítače a přepnutí do režimu spánku

Vypnutí počítače

procedure TForm1.Button1Click(Sender: TObject);
  var dwReserved: DWord;
begin
 ExitWindowsEx(EWX_SHUTDOWN, dwReserved); // místo parametru dwReserved může být hodnota 0
end;

Odhlášení uživatele

procedure TForm1.Button1Click(Sender: TObject);
  var dwReserved: DWord;
begin
 ExitWindowsEx(EWX_LOGOFF, dwReserved);
end;

Restart počítače

procedure TForm1.Button1Click(Sender: TObject);
  var dwReserved: DWord;
begin
 ExitWindowsEx(EWX_REBOOT, dwReserved);
end;

Přepnutí počítače do režimu spánku

SetSystemPowerState(True, True);

Vysunutí a zasunutí CD mechaniky

uses MMSystem;

mciSendString('Set cdaudio door open wait', nil, 0, Handle);   // vysune CD mechaniku
mciSendString('Set cdaudio door closed wait', nil, 0, Handle); // zasune CD mechaniku

Vysunutí nabídky Start

procedure TForm1.Button1Click(Sender: TObject);
  var Wnd: HWnd;
begin
 Wnd:=FindWindow('Progman', nil);
 SendMessage(Wnd, WM_SYSCOMMAND, SC_TASKLIST, 0);
end;

Vytvoření zástupce souboru

uses FileCtrl, ShlObj, ActiveX, ComObj;

Procedure CreateLink(ShortCutFile: WideString; TargetFile, WorkingDirectory, Arguments, Description, IconPath: string;
 IconIndex: integer);
  var MyObject: IUnknown;
        MySLink: IShellLink;
        MyPFile: IPersistFile;
begin
 MyObject:=CreateComObject(CLSID_ShellLink);
 MySLink:=MyObject as IShellLink;
 MyPFile:=MyObject as IPersistFile;
  with MySLink do
   begin
    SetPath(PChar(TargetFile));
    SetWorkingDirectory(PChar(WorkingDirectory));
    SetArguments(PChar(Arguments));
    SetDescription(PChar(Description));
    SetIconLocation(PChar(IconPath), IconIndex);
   end;
 MyPFile.Save(PWChar(ShortCutFile), False);
 MySLink:=nil;
 MyPFile:=nil;
 MyObject:=nil;
end;

Zachycení obsahu obrazovky

procedure TForm1.Button1Click(Sender: TObject);
  var DesktopBitmap: TBitmap;
        DesktopWnd: HWnd;
        DC: HDC;
begin
 DesktopBitmap:=TBitmap.Create;
 DesktopBitmap.Width:=Screen.Width;
 DesktopBitmap.Height:=Screen.Height;
 DesktopWnd:=GetDesktopWindow;
 DC:=GetWindowDC(DesktopWnd);
 BitBlt(DesktopBitmap.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, GetDC(GetDesktopWindow), 0, 0, SrcCopy);
 DesktopBitmap.SaveToFile('C:\Obrazovka.bmp');
 ReleaseDC(DesktopWnd, DC);
 DesktopBitmap.Free;
end;

Zakázání a povolení pohybu formuláře

DeleteMenu(GetSystemMenu(Handle, False), SC_MOVE, MF_BYCOMMAND); // zakázání pohybu
GetSystemMenu(Handle, True);                                                                                // povolení pohybu

Zakázání a povolení překreslování okna aplikace

SendMessage(Handle, WM_SetRedraw, 0, 0); // zakázání překreslování
SendMessage(Handle, WM_SetRedraw, 1, 0); // povolení překreslování

Zakázání a povolení tlačítka pro zavření formuláře

Procedure EnableCloseButton(const Enable: boolean);
  const MenuFlags: array[Boolean] of integer = (MF_DISABLED, MF_ENABLED);
  var Menu: HMenu;
begin
 Menu:=GetSystemMenu(Form1.Handle, False);
  if Menu > 0 then
   EnableMenuItem(Menu, SC_CLOSE, MF_BYCOMMAND or MenuFlags[Enable]);
end;

Zakázání a povolení Windowsovských kláves a kombinace CTRL+ALT+DEL

Procedure DisableWinKeys(Disable: boolean);
  var Dummy: integer;
begin
 SystemParametersInfo(SPI_SETFASTTASKSWITCH, Ord(Disable), @Dummy, 0);     // ALT+TAB a CTRL+ESC
 SystemParametersInfo(SPI_SCREENSAVERRUNNING, Ord(Disable), @Dummy, 0); // CTRL+ALT+DEL
end;

Zalomení textu tlačítka na více řádků

Function SetMultiLine(Ctrl: TButtonControl): boolean;
  var Style: DWord;
begin
 Style:=GetWindowLong(Ctrl.Handle, GWL_STYLE);
 SetLastError(0);
 SetWindowLong(Ctrl.Handle, GWL_STYLE, Style or BS_MULTILINE);
 Result:=(GetLastError = 0);
  if Result then Ctrl.Repaint;
end;

Zapnutí a vypnutí kláves Num Lock, Caps Lock a Scroll Lock

Procedure KeySwitchOn(Key: byte; State: boolean);
  var KeyState: TKeyboardState;
begin
 GetKeyboardState(KeyState);
 KeyState[Key]:=Ord(State);
 SetKeyboardState(KeyState);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 KeySwitchOn(VK_NUMLOCK, True); // VK_CAPITAL, VK_SCROLL
end;

Zapnutí a vypnutí spořiče obrazovky

SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, 0); // zapne spořič
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, 0); // vypne spořič

Získání ikony přidružené k souboru

uses ShellApi;

Function GetShellIcon(FileName: string; Folder: boolean): HIcon;
  var FileInfo: TSHFileInfo;
        Flag: integer;
begin
  if Folder then Flag:=FILE_ATTRIBUTE_DIRECTORY
   else Flag:=FILE_ATTRIBUTE_NORMAL;
 SHGetFileInfo(PChar(FileName), Flag, FileInfo, SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON or
  SHGFI_USEFILEATTRIBUTES);
 Result:=FileInfo.hIcon;
end;

Získání ikony ze souboru nebo knihovny

uses ShellApi;

Image1.Picture.Icon.Handle:=ExtractIcon(HInstance, PChar(Application.ExeName), 0);
// poslední parametr určuje index ikony

Zjištění a nastavení hlasitosti WAVů

Zjištění hlasitosti

uses MMSystem;

Function GetWaveVolume: DWord;
  var Woc: TWaveOutCaps;
         Volume: DWord;
begin
 if (WaveOutGetDevCaps(WAVE_MAPPER, @Woc, SizeOf(Woc)) = MMSYSERR_NOERROR) and
  (Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME) then
   begin
    WaveOutGetVolume(WAVE_MAPPER, @Volume);
    Result:=Volume;
   end;
end;

Nastavení hlasitosti

uses MMSystem;

Procedure SetWaveVolume(const Volume: DWord);
  var Woc: TWaveOutCaps;
begin
 if (WaveOutGetDevCaps(WAVE_MAPPER, @Woc, SizeOf(Woc)) = MMSYSERR_NOERROR) and
  (Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME) then
   WaveOutSetVolume(WAVE_MAPPER, Volume); // proměnná Volume udává hlasitost, maximální hodnota je 65535
end;

Zjištění cesty k důležitým systémovým složkám

uses ShlObj;

Function GetSpecialDir(SpecialDir: integer): string;
  var Pidl: PItemIDList;
        Path: array[0..MAX_PATH] of Char;
begin
 SHGetSpecialFolderLocation(Form1.Handle, SpecialDir, Pidl);
 SHGetPathFromIDList(Pidl, Path);
 Result:=Path;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(GetSpecialDir(CSIDL_HISTORY));
end;

CSIDL_DESKTOP
CSIDL_INTERNET
CSIDL_PROGRAMS
CSIDL_CONTROLS
CSIDL_PRINTERS
CSIDL_PERSONAL
CSIDL_FAVORITES
CSIDL_STARTUP
CSIDL_RECENT
CSIDL_SENDTO
CSIDL_BITBUCKET
CSIDL_STARTMENU
CSIDL_DESKTOPDIRECTORY
CSIDL_DRIVES
CSIDL_NETWORK
CSIDL_NETHOOD
CSIDL_FONTS
CSIDL_TEMPLATES
CSIDL_COMMON_STARTMENU
CSIDL_COMMON_PROGRAMS
CSIDL_COMMON_STARTUP
CSIDL_COMMON_DESKTOPDIRECTORY
CSIDL_APPDATA
CSIDL_PRINTHOOD
CSIDL_ALTSTARTUP
CSIDL_COMMON_ALTSTARTUP
CSIDL_COMMON_FAVORITES
CSIDL_INTERNET_CACHE
CSIDL_COOKIES
CSIDL_HISTORY

Zjištění Handle a titulku okna aktivní aplikace

Handle

procedure TForm1.Button1Click(Sender: TObject);
  var Handle: HWnd;
begin
 Handle:=GetActiveWindow;
end;

Titulek

Function GetActiveTitle: string;
  var PC: array[0..$FFF] of Char;
        Handle: HWnd;
begin
 Handle:=GetForegroundWindow;
 SendMessage(Handle, WM_GETTEXT, $FFF, Longint(@PC));
 Result:=StrPas(PC);
end;

Zjištění Handle okna jiné aplikace

procedure TForm1.Button1Click(Sender: TObject);
  var Handle: HWnd;
begin
 Handle:=FindWindow(nil, 'titulek');
end;

Zjištění přítomnosti média v diskové jednotce

Function DiskInDrive(const Drive: Char): boolean;
  var DrvNum: byte;
        EMode: Word;
begin
 Result:=False;
 DrvNum:=Ord(Drive);
  if DrvNum >= Ord('A') then Dec(DrvNum, $20);
 EMode:=SetErrorMode(SEM_FAILCRITICALERRORS);
  try
   if DiskSize(DrvNum - $40) <> -1 then Result:=True
    else MessageBeep(0);
  finally
   SetErrorMode(EMode);
  end;
end;

Zjištění stavu kláves

if GetKeyState(VK_SHIFT) and $80 <> 0 then ShowMessage('Klávesa SHIFT je stisknutá.');

Zjištění umístění složky Windows a Temp

Umístění složky Windows

Function GetWinDir: string;
  var Path: array[0..MAX_PATH] of Char;
begin
 GetWindowsDirectory(Path, SizeOf(Path) - 1);
 Result:=StrPas(Path);
end;

Umístění složky Temp

Function GetTempDir: string;
  var Path: array[0..MAX_PATH] of Char;
begin
 GetTempPath(SizeOf(Path) - 1, Path);
 Result:=StrPas(Path);
end;

Zjištění velikosti složky včetně podsložek

Function GetDirSize(Dir: string; SubDir: boolean): longint;
  var Rec: TSearchRec;
        Found: integer;
begin
 Result := 0;
  if Dir[Length(Dir)] <> '\' then Dir:=Dir + '\';
 Found:=FindFirst(Dir + '*.*', faAnyFile, Rec);
  while Found = 0 do
   begin
    Inc(Result, Rec.Size);
     if (Rec.Attr and faDirectory > 0) and (Rec.Name[1] <> '.') and (SubDir = True) then
      Inc(Result, GetDirSize(Dir + Rec.Name, True));
    Found:=FindNext(Rec);
   end;
 FindClose(Rec);
end;

Zkrácený zápis názvů složek a souborů

Function ShortPath(MaxLength: integer; Path: string): string;
  var Index: integer;
begin
  if Length(Path) > MaxLength then
   begin
    Index:=Pos('\', Copy(Path, Length(Path) - MaxLength + 3, MaxLength));
    Result:=Copy(Path, 1, 3) + '..' + Copy(Path, Length(Path) - MaxLength + 2 + Index, MaxLength);
   end
  else
   Result:=Path;
end;

Změna barvy ukazatele ProgressBaru

uses CommCtrl;

SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, clRed);

Změna pozadí pracovní plochy

Stálá změna pozadí

uses Registry;

Procedure Wallpaper(FileName: string; Dlazdice: boolean; Pozice: integer);
  var Reg: TRegIniFile;
begin
 Reg:=TRegIniFile.Create('Control Panel\Desktop');
 Reg.WriteString('', 'Wallpaper', FileName);
 Reg.WriteString('', 'TileWallpaper', IntToStr(Ord(Dlazdice)));
 Reg.WriteString('', 'WallpaperStyle', IntToStr(Pozice));
 Reg.Free;
 SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Wallpaper('C:\Pozadí.bmp', False, 2);
end;

Dočasná změna pozadí

SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar('C:\Pozadí.bmp'), 0);

Změna rozlišení

Změna rozlišení

procedure TForm1.Button1Click(Sender: TObject);
  var DevMode: TDeviceMode;
begin
  with DevMode do
   begin 
    dmSize:=SizeOf(TDeviceMode);
    dmPelsWidth:=800;
    dmPelsHeight:=600;
    dmBitsPerPel:=32;
    dmFields:=DM_PELSWIDTH + DM_PELSHEIGHT + DM_BITSPERPEL;
   end;
 ChangeDisplaySettings(DevMode, 0);
end;

Vrácení původního rozlišení

ChangeDisplaySettings(PDevMode(nil)^, 0);

Změna velikosti okna přehrávaného videa

MediaPlayer1.DisplayRect:=ClientRect;