Chip 2003 November/Chip_2003-11_cd1.bin/program/delphi/kompon/DIHtmlLabel.exe/Demos/DIHtmlLabel/Main.pas

Pascal/Delphi Source File | 2003-09-01 | 7.1 KB | 268 lines

{ DIHtmlLabel example. }

unit Main;

{$I DI.inc}

{.$DEFINE Debug}// Default: Off

interface

uses
  Classes, Forms, StdCtrls, ExtCtrls, Controls,

  CategCh,

  DIHtmlLabel;

type
  TfrmMain = class(TForm)
    DIHtmlLabel: TDIHtmlLabel;
    edtDynamic: TEdit;
    pnlTop: TPanel;
    lblClose: TLabel;
    lblWelcome: TLabel;
    lblHtmlLabel: TLabel;
    pnlBlackLine: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure lblCloseClick(Sender: TObject);
    procedure DIHtmlLabelLinkClick(const Sender: TObject; const LinkHref: WideString; const LinkText: WideString);
    procedure DIHtmlLabelDynamicTagInit(const Sender: TObject; const ID: WideString; out Source: string);
    procedure pnlTopMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; x, y: Integer);
    procedure edtDynamicChange(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    FCategoryChooser: TCategoryChooser;
    procedure CategoryChooserCatChange(Sender: TObject);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure OpenFormPlay;
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

uses
  Windows, Messages, ShellAPI, Graphics, Dialogs,

  InfoStrings, Play,

  DIHtmlCharSetPlugin,
  DIUtils;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.FormCreate(Sender: TObject);

  procedure TryFonts(const FontNames: array of AnsiString);
  var
    i: Integer;
  begin
    for i := Low(FontNames) to High(FontNames) do
      if Screen.Fonts.IndexOf(FontNames[i]) >= 0 then
        begin
          Font.Name := FontNames[i];
          Break;
        end;
  end;

var
  i: Integer;
begin
  DoubleBuffered := True;
  TryFonts(['Verdana', 'Tahoma', 'Arial', 'Times New Roman']);

  lblWelcome.Font.Color := clHighlightText;
  lblWelcome.Font.Size := 14;
  lblWelcome.Font.Style := [fsBold];

  lblHtmlLabel.Font.Color := clHighlightText;
  lblHtmlLabel.Font.Size := 24;
  lblHtmlLabel.Font.Style := [fsBold];

  lblClose.Font.Color := clHighlightText;
  lblClose.Font.Size := 12;
  lblClose.Font.Style := [fsBold, fsUnderline];
  lblClose.Cursor := crHandPoint;

  DIHtmlLabel.Font.Size := 9;

  { We create the TCategoryChooser dynamically,
    so that the user doesn't need to install it. }
  FCategoryChooser := TCategoryChooser.Create(Self);
  FCategoryChooser.SetBounds(
    0,
    pnlBlackLine.Top + pnlBlackLine.Height,
    DIHtmlLabel.Left - 4,
    ClientHeight - pnlBlackLine.Top - pnlBlackLine.Height);
  FCategoryChooser.OnCatChange := CategoryChooserCatChange;
  for i := Low(Headings) to High(Headings) do
    FCategoryChooser.CatList.Add(Headings[i]);
  FCategoryChooser.Parent := Self;
  FCategoryChooser.Font.Style := [fsBold];
  CategoryChooserCatChange(FCategoryChooser);

  {$IFDEF Debug}
  OpenFormPlay;
  {$ENDIF}
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.CreateParams(var Params: TCreateParams);
begin
  { We should really create a new TCustomForm-descendant, called
    TMovableBorderForm or something like that, that we'd inherit from, instead
    of placing all this nasty Windows-specific code directly in our main form.
    However, that would probably cause trouble with the form designer, and we'd
    wind up with creating everything dynamically. Visual form inheritance could
    probably help us out, but this is just a demo application, and we'd just be
    complicating matters unnecessarily. }
  inherited;
  with Params do
    Style := (Style or WS_POPUP or WS_BORDER) and not WS_DLGFRAME;
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.CategoryChooserCatChange(Sender: TObject);
begin
  with FCategoryChooser do
    if SelectedCat in [Low(Info)..High(Info)] then
      DIHtmlLabel.Caption := Info[SelectedCat];
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = #27 { Escape } then
    begin
      Close;
      Key := #0;
    end;
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.lblCloseClick(Sender: TObject);
begin
  Close;
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.OpenFormPlay;
begin
  with TfrmPlay.Create(nil) do
    try
      ShowModal;
    finally
      Free;
    end;
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.DIHtmlLabelLinkClick(
  const Sender: TObject;
  const LinkHref: WideString;
  const LinkText: WideString);

  procedure GoToNextCategory(const i: Integer);
  begin
    { This should really belong to the TCategoryChooser itself. }
    with FCategoryChooser do
      SelectedCat := SelectedCat + i;
  end;

  { ---------- }

  procedure DisplayLink;
  begin
    ShowMessage(
      'This link is identified by:' +
      CRLF + CRLF + '"' + LinkHref + '"' + CRLF + CRLF +
      'It contains the following text:'
      + CRLF + CRLF + '"' + LinkText + '"');
  end;

  { ---------- }

  procedure OpenUrl;
  begin
    ShellExecute(0, 'open', PAnsiChar(AnsiString(LinkHref)), nil, nil, SW_SHOWNORMAL);
  end;

  { ---------- }

begin
  if StrSameIW(LinkHref, 'Next') then
    GoToNextCategory(1)
  else
    if StrSameIW(LinkHref, 'Next2') then
      GoToNextCategory(2)
    else
      if StrSameIW(LinkHref, 'Next3') then
        GoToNextCategory(3)
      else
        if StrSameIW(LinkHref, 'Next4') then
          GoToNextCategory(4)
        else
          if StrSameIW(LinkHref, 'Show') then
            DisplayLink
          else
            if StrSameIW(LinkHref, 'Play') then
              OpenFormPlay
            else
              if StrSameStartIW(LinkHref, 'http://') then
                OpenUrl;
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.DIHtmlLabelDynamicTagInit(
  const Sender: TObject;
  const ID: WideString;
  out Source: string);
begin
  Source := edtDynamic.Text;
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.pnlTopMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; x, y: Integer);
const
  SC_DRAGMOVE = SC_MOVE + HTCAPTION;
begin
  ReleaseCapture;
  Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.edtDynamicChange(Sender: TObject);
begin
  DIHtmlLabel.UpdateDynamicTag('', edtDynamic.Text);
end;

{ ---------------------------------------------------------------------------- }

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  ShowMessage(DIHtmlLabel.GetDynamicTagContents(''));
end;

{ ---------------------------------------------------------------------------- }

initialization
  RegisterCharSets;

end.