Tipy a triky v Delphi, díl 12.

Hrátky s pracovní plochou Windows – to je dnešní téma. Naučíme se jednak změnit tapetu na ploše a dále vytvořit zástupce na ploše a prakticky v libovolném adresáři.
Změna tapety

Ukážeme si dva způsoby, jak změnit tapetu pracovní plochy. První pracuje přímo s registry a je řekněme komplexnější, druhý způsob je zase o něco kratší. Osobně bych se přikláněl k prvnímu způsobu, protože i zdrojový kód je o něco přehlednější a jasnější.

Tak tedy první způsob. Jak bylo řečeno, budeme pracovat s registry, takže nezapomeňte připojit jednotku Registry.

procedure Wallpaper(nazevsouboru:string;dlazdice,roztahnout:boolean);
var  reg : TRegIniFile;
begin
reg := TRegIniFile.Create(`Control Panel\Desktop`);
with reg do
  begin

  WriteString(``, `Wallpaper`, nazevsouboru);
  if dlazdice then WriteString(``, `TileWallpaper`, `1`)
              else WriteString(``, `TileWallpaper`, `0`);

  if roztahnout then WriteString(``, `WallpaperStyle`, `2`)
                else WriteString(``, `WallpaperStyle`, `0`);

  end;
  reg.Free;
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil, SPIF_SENDWININICHANGE);
end;

Prvním parametrem je obrázek ve formátu BMP, který bude použit jako tapeta. Druhý parametr logického typu nám určuje, zda se má obrázek nakopírovat na plochu vedle sebe (v případě, že není dostatečně velký), a nakonec třetím parametrem nastavíme, jestli se má obrázek roztáhnout (místo aby se nakopíroval vedle sebe). Myslím, že to každý stejně dobře zná a není třeba nic více vysvětlovat.

Ještě přidám malou tabulku, ve které přesně vidíte, jaké parametry pro daný způsob používají samotná Windows, abyste se vyvarovali "nestandardních" kombinací :

"Na střed" - TileWallpaper="0" WallpaperStyle="0"

"Vedle sebe" - TileWallpaper="1" WallpaperStyle="0"

"Roztáhnout" - TileWallpaper="0" WallpaperStyle="2"

Druhý způsob je kratší, tapetu zobrazí na střed a parametrem je pouze soubor s obrázkem. Návratovým parametrem funkce je true nebo false v závislosti na úspěšném či neúspěšném pokusu o provedení akce.

function Wallpaper(soubor: string):boolean;
type a=array [0..255] of char;
var nazev: ^a;
begin
new(nazev);
strpcopy(nazev^,soubor);
dispose(nazev);
if SystemParametersInfo(SPI_SETDESKWALLPAPER,0,nazev,SPIF_SENDCHANGE ) then Result:=true
else Result:=false;
end;

Na závěr jedno téma na volnou diskusi. Jeden ze čtenářů přišel se zajímavým dotazem, zda by nebylo možné nejen tapetu tímto celkem jednoduchým způsobem změnit, ale jestli by nebylo možné přímo tuto bitmapu animovat. Pokud snad někdo ví, zda a jak je to možné provést, ať nám zkusí poradit v diskusi. Jde nám ale o opravdovou animaci, ne o pouhé "rychlé" střídání obrazovek, které by mělo do plynulosti daleko.

Vytvoření zástupce

Další věcí, kterou se naučíme, bude vytváření zástupců, a to nejen na ploše, ale též v menu Start, v panelu rychlého spuštění a prakticky v libovolné složce, kterou si zvolíte.

Potřeba budou tyto knihovny: Registry, ActiveX, Comobj, ShlObj

Vše potřebné zajistí následující procedura CreateShortCut, kterou potom v naší ukázce použijeme ke konkrétnímu příkladu vytvoření několika zástupců po stisknutí tlačítka.

Vytvořit můžeme zástupce několika druhů a jejich typy jsou nadefinovány hned na začátku. Pro upřesnění malý přehled v češtině:

_DESKTOP = pracovní plocha

_QUICKLAUNCH = panel rychlého spuštění (vpravo od tlačítka Start při standardním nastavení systému)

_SENDTO = odeslat (položka kontextového menu pravého tlačítka)

_STARTMENU = snad není třeba vysvětlovat :)

_OTHERFOLDER = libovolný jiný adresář, kde hodláte vytvořit zástupce

Zde tedy uvádíme zdrojový kód procedury včetně definice typů zástupce:

type ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER);

procedure CreateShortcut(SourceFileName: string; Location: ShortcutType; SubDirectory : string);
var
  MyObject : IUnknown;
  MySLink  : IShellLink;
  MyPFile  : IPersistFile;
  Directory,
  LinkName  : string;
  WFileName : WideString;
  MyReg,
  QuickLaunchReg : TRegIniFile;
begin
  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;

  MySLink.SetPath(PChar(SourceFileName));

  MyReg := TRegIniFile.Create(`Software\MicroSoft\Windows\CurrentVersion\Explorer`);
  try
    LinkName := ChangeFileExt(SourceFileName, `.lnk`);
    LinkName := ExtractFileName(LinkName);
    case Location of
      _OTHERFOLDER  : Directory := SubDirectory;
      _DESKTOP      : Directory := MyReg.ReadString(`Shell Folders`, `Desktop`, ``);
      _STARTMENU    : Directory := MyReg.ReadString(`Shell Folders`, `Start Menu`, ``);
      _SENDTO      : Directory := MyReg.ReadString(`Shell Folders`, `SendTo`, ``);
      _QUICKLAUNCH:
        begin
          QuickLaunchReg := TRegIniFile.Create(`Software\MicroSoft\Windows\CurrentVersion\GrpConv`);
          try
            Directory := QuickLaunchReg.ReadString(`MapGroups`, `Quick Launch`, ``);
          finally
            QuickLaunchReg.Free;
          end;
        end;
    end;
    if Directory <> `` then
      begin
        if (SubDirectory <> ``) and (Location <> _OTHERFOLDER) then
        WFileName := Directory + `\`+ SubDirectory +`\` + LinkName
        else
        WFileName := Directory + `\` + LinkName;
        MyPFile.Save(PWChar(WFileName), False);
      end;
  finally
    MyReg.Free;
  end;
end;

A zde již konkrétní příklad vytvoření několika zástupců. Vytvoříme si zástupce na ploše, v menu Start, v panelu rychlého spuštění a v jednom dalším libovolném adresáři.

procedure TForm1.Button1Click(Sender: TObject);
begin
CreateShortcut(`c:\Vasprogram.exe`,_STARTMENU,`Programy`);
CreateShortcut(`c:\Vasprogram.exe`,_DESKTOP,``);
CreateShortcut(`c:\Vasprogram.exe`,_OTHERFOLDER,`c:\Vasadresar`);
CreateShortcut(`c:\Vasprogram.exe`,_QUICKLAUNCH,``);
end;

Jak vidíte, prvním parametrem je soubor včetně cesty, jehož zástupce vytváříme. Dále je to umístění zástupce, tj. jeden z výše definovaných typů, a nakonec je to volitelně přímo jméno složky (ať už na disku či v menu Start), kde bude zástupce vytvořen.

No a to je pro dnešek vše. Příště se zaměříme na některé funkce a tipy spojené se soubory a prací s nimi.

Diskuze (5) Další článek: AMD oficiálně vypustilo procesory Athlon XP

Témata článku: Software, Windows, Programování, DEL, Trik, První parametr, TRI, Elsa, Díl, Wallpaper, Shell, První spuštění, Definovaný typ, Libovolný soubor


Určitě si přečtěte

Archivovat data do cloudu, na HDD, SSD, DVD, nebo Blu-ray? Co je nejvýhodnější?

Archivovat data do cloudu, na HDD, SSD, DVD, nebo Blu-ray? Co je nejvýhodnější?

** Kam doma natrvalo uložit data? Vyplatí se ještě optická média? ** Jaké kapacity disků a médií má smysl koupit? ** Cenovou výhodnost si ukážeme na příkladech s 2TB úložištěm

Lukáš Václavík | 118

Lukáš Václavík
ZálohováníÚložištěPevné disky
Testy procesorů Ryzen 5000: AMD překonalo Intel ve všech směrech

Testy procesorů Ryzen 5000: AMD překonalo Intel ve všech směrech

** AMD začalo prodávat nové procesory Ryzen 5000 s architekturou Zen 3 ** K dispozici jsou nezávislé testy z celého světa ** AMD překonává Intel ve všech směrech

Karel Javůrek | 69

Karel Javůrek
ProcesoryTestyAMD
Starlink podle betatesterů: Rychlejší a levnější než satelitní internet v Česku

Starlink podle betatesterů: Rychlejší a levnější než satelitní internet v Česku

** Reddit se začíná plnit zkušenostmi se Starlinkem ** Při přímé viditelnosti dá i 120 Mb/s ** Klasický satelitní internet už teď dalece překonává

Jakub Čížek | 48

Jakub Čížek
StarlinkPoskytovatelé internetu
Vybrali jsme 12 programovatelných hraček a stavebnic pro děti a jejich rodiče

Vybrali jsme 12 programovatelných hraček a stavebnic pro děti a jejich rodiče

** Získejte děti pro matematiku a základy techniky ** Kupte jim hračku nebo stavebnici, které vdechnou vlastní život ** Vybrali jsme stavebnice pro malé caparty i budoucí experty

Jakub Čížek | 10

Jakub Čížek
Stavebnice
Zapomeňte na destičky. Raspberry Pi 400 je nový počítač zabudovaný do klávesnice
Lukáš Václavík
Raspberry PiPočítače
Nejlepší notebooky do 20 000 Kč. Tipy, co se dnes vyplatí koupit

Nejlepší notebooky do 20 000 Kč. Tipy, co se dnes vyplatí koupit

** S cenou do 20 tisíc lze vybrat solidní notebook na práci i hry ** Přenosné notebooky nabídnou i kovová těla a rychlý hardware ** Možná největší problém je nedostupnost, nejžádanější kusy jsou vyprodané

David Polesný | 33

David Polesný
VánoceNotebooky
Apple Macbook Air M1: testujeme výkon, výdrž, a hlavně kompatibilitu aplikací [průběžně aktualizováno]

Apple Macbook Air M1: testujeme výkon, výdrž, a hlavně kompatibilitu aplikací [průběžně aktualizováno]

** Testujeme Apple Macbook Air s procesorem M1 ** Zajímá nás nejen výkon, ale zejména kompatibilita aplikací ** Článek je průběžně doplňován na základě vašich dotazů

Jiří Kuruc | 205

Jiří Kuruc
Apple
Šéf Spotify: Budeme zdražovat. Náš obsah se zlepšil
Markéta Mikešová
PředplatnéSpotify

Aktuální číslo časopisu Computer

Jak prodloužit výdrž notebooku

Velké testy: gamepady a inkoustové tiskárny

Důkladný test Sony Playstation 5