Tipy a triky v Delphi, díl 69.

Několik drobných tipů pro komponentu RichEdit, to bude náplní celého dnešního dílu.
Ukážeme si dnes několik vylepšení standardní komponenty RichEdit. Bude se jednat o čtyři ukázky a jelikož spolu všechny vzájemně souvisí, budou součástí jednoho zdrojového kódu, který naleznete v druhé polovině článku.

Na formulář umístěte komponentu RichEdit a dále tři tlačítka. Ta budou sloužit pro jednotlivé funkce, přičemž čtvrtá slibovaná funkce bude aktivována automaticky.

První tlačítko nám poslouží pro barevné zvýraznění vybraného textu. Musím zdůraznit, že vybraného textu, protože se toto pravidlo bude týkat i dalších dvou funkcí. Po označení textu a kliknutí na tlačítko bude mít text světle zelené pozadí. Pochopitelně si můžete barvu libovolně zvolit, protože je součástí parametrů.

Druhé a třetí tlačítko slouží pro nastavení horního a dolního indexu vybraného textu. Znamená to tedy, že označený text bude posunut oproti úrovni ostatního textu o půl řádku výš nebo níž a vytvoří se tak dojem horního a dolního indexu. Řešení to sice není úplně ideální, ale pokud máte v textu jen několik míst, kde je třeba horní či dolní index nastavit, dá se celkem použít.

Poslední funkce, která však není spouštěna tlačítkem a běží automaticky, je zvýrazňování webových adres v textu. Bude-li tedy text identifikován jako webová adresa, změní se na odkaz, tj. bude mít modrou barvu, kurzor myši bude mít podobu ruky a po kliknutí na odkaz se samozřejmě otevře příslušná webová stránka (pochopitelně v prohlížeči, ne v komponentě RichEdit).

K fungování našich příkladů budeme potřebovat knihovnu RichEdit a kvůli spouštění webové stránky rovněž ShellAPI. Zde je tedy celý zdrojový kód:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, RichEdit, ShellAPI;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  protected
    procedure WndProc(var Message: TMessage); override;

  end;

  TCharacterFormat = (CFM_Superscript, CFM_Subscript, CFM_Normal);


var
  Form1: TForm1;

implementation

{$R *.dfm}

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

procedure SetCharFormat(RichEdit: TRichEdit; CharacterFormat: TCharacterFormat);
var
  Format: TCharFormat;
begin
  FillChar(Format, SizeOf(Format), 0);
  with Format do
  begin
    cbSize := SizeOf(Format);
    dwMask := CFM_OFFSET;
    case CharacterFormat of
      CFM_Superscript: yOffset := 60;
      CFM_Subscript: yOffset := -60;
      CFM_Normal: yOffset := 0;
    end;
  end;
  Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetSelBgColor(RichEdit1, clLime);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SetCharFormat(RichEdit1, CFM_Superscript);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  SetCharFormat(RichEdit1, CFM_Subscript);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  mask: Word;
begin
  mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
  SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);
end;

procedure TForm1.WndProc(var Message: TMessage);
var
  p: TENLink;
  strURL: string;
begin
  if (Message.Msg = WM_NOTIFY) then
  begin
    if (PNMHDR(Message.lParam).code = EN_LINK) then
    begin
      p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);
      if (p.Msg = WM_LBUTTONDOWN) then
      begin
        SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
        strURL := RichEdit1.SelText;
        ShellExecute(Handle, `open`, PChar(strURL), 0, 0, SW_SHOWNORMAL);
      end
    end
  end;
  inherited;
end;

end.

Na závěr jako už tradičně opět zmínka o operačních systémech. Nevím, zda je to problém pouze mého počítače, ale pod Windows 98 mi příklady nefungovaly. V systému Windows 2000 ale vše pracovalo bezproblémově a správně a předpokládám, že ani pod XP nebudou potíže.

Diskuze (7) Další článek: Společnosti VIA a SiS zveřejnily hospodářské výsledky za listopad

Témata článku: Software, Windows, Programování, Message, Trik, Zelené pozadí, Format, Díl, Pointer


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

Sex a rozmnožování při mezihvězdné cestě: Kolik lidí je potřeba pro let k Proximě Centauri?

Sex a rozmnožování při mezihvězdné cestě: Kolik lidí je potřeba pro let k Proximě Centauri?

** Vědci spočítali, jak velká by musela být posádka pro vícegenerační let k nejbližší hvězdné soustavě ** Proxima Centauri se nachází 4,3 světelných let od nás ** Za současných technologií bychom k ní letěli 6300 let

Petr Kubala | 53

Takhle zemřete, když asteroid dopadne na vaše město

Takhle zemřete, když asteroid dopadne na vaše město

** Jak by to dopadlo, kdyby na světovou metropoli či do nedalekého moře dopadl velký asteroid? ** Simulovali to odborníci z University of Southampton ** Výsledky jsou velmi zajímavé

Petr Kubala | 32

Alan Turing: Genius, který matematicky stvořil počítač

Alan Turing: Genius, který matematicky stvořil počítač

Řešením matematického problému se dostal k modelu teoretického stroje, který nese jeho jméno a je základem logiky univerzálních počítačů.

Pavel Tronner | 56

Apple: naše mapy budou nejlepší na světě. Tajně jsme na nich pracovali několik let

Apple: naše mapy budou nejlepší na světě. Tajně jsme na nich pracovali několik let

** Apple odhalil své plány na zcela nové mapy ** Několik let pracuje na nových mapách, které by měly předběhnout konkurenci ** Objeví se s příchodem iOS 12 pro vybrané státy

Karel Javůrek | 50

Jak dopadl velký den Applu s náloží novinek: Sledujte, co letos připravil

Jak dopadl velký den Applu s náloží novinek: Sledujte, co letos připravil

** Apple večer představil novinky ** Ukáže nové operační systémy, ale čekala se i nová zařízení ** Začíná vývojářská konference Applu WWDC 2018

Karel Javůrek | 87

Google ADT-2: Miniaturní krabička s Android TV 8.0, kterou si nikdy nekoupíte

Google ADT-2: Miniaturní krabička s Android TV 8.0, kterou si nikdy nekoupíte

** Dlouho se nevědělo, co to přesně má být ** Pak se s krabičkou Google pochlubil na I/O ** Do „Chromecastu“ vtěsnal celý Android TV

Jakub Čížek | 24

Budoucnost elektroniky: čeští vědci stojí za revolučním čipem, který nemá ve světě obdoby

Budoucnost elektroniky: čeští vědci stojí za revolučním čipem, který nemá ve světě obdoby

** Čeští vědci pod vedením Tomáše Jungwirtha vyvíjí nový typ revolučního paměťového čipu ** Zatímco v současnosti elektronika pracuje s elektrony, v budoucnu to budou spiny elektronů ** Čipy budou moci být klidně i 1 000x rychlejší a úspornější

Karel Javůrek | 32


Aktuální číslo časopisu Computer

Velký test 18 bezdrátových sluchátek

Vše o přechodu na DVB-T2

Procesory AMD opět porážejí Intel

7 NVMe M.2 SSD v přímém souboji