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

Pascal/Delphi Source File | 2003-07-23 | 18.3 KB | 606 lines

unit DIHtmlLabel;

{$I DI.inc}

interface

uses
  Windows, Messages, Classes, Graphics, Controls,

  DIHtmlRenderer;

const
  DIHTMLLABEL_DEFAULT_AUTO_HEIGHT = True;
  DIHTMLLABEL_DEFAULT_HOT_LINKS = True;
  DIHTMLLABEL_DEFAULT_LINK_COLOR = clBlue;
  DIHTMLLABEL_DEFAULT_LINK_COLOR_CLICKED = clRed;
  DIHTMLLABEL_DEFAULT_LINK_COLOR_HOT = clPurple;
  DIHTMLLABEL_DEFAULT_LINK_STYLE = [fsUnderline];

type
  TDICustomHtmlLabel = class;

  TLinkClickEvent = procedure(
    const Sender: TObject;
    const LinkHref: WideString;
    const LinkText: WideString) of object;

  TDynamicTagInitEvent = procedure(
    const Sender: TObject;
    const ID: WideString;
    out Source: AnsiString) of object;

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

  // TDICustomHtmlLabel = class(TGraphicControl, IDynamicNodeHandler)
  TDICustomHtmlLabel = class(TCustomControl, IDynamicNodeHandler)
  private
    FCaption: AnsiString;
    FRenderer: TDIHtmlRenderer;
    FActiveLinkNode: TLinkNode;
    FHotLinks: Boolean;
    FRect: TRect;
    FAutoHeight: Boolean;
    FMarginWidth: Integer;
    FMarginHeight: Integer;
    FOriginalCursor: TCursor;
    FOnLinkClick: TLinkClickEvent;
    FOnDynamicTagInit: TDynamicTagInitEvent;
    FOnAfterPaint: TNotifyEvent;
    procedure SetTransparent(const Value: Boolean);
    function GetLinkColor: TColor;
    function GetLinkStyle: TFontStyles;
    procedure SetLinkColor(const Value: TColor);
    procedure SetLinkStyle(const Value: TFontStyles);
    procedure SynchronizeRootAndFont;
    function GetLinkColorClicked: TColor;
    procedure SetLinkColorClicked(const Value: TColor);
    function GetLinkColorHot: TColor;
    procedure SetLinkColorHot(const Value: TColor);
    procedure ActivateLinkNodeAtPos(const p: TPoint; State: TLinkState);
    procedure DeactivateActiveLinkNode;
    procedure HandleDynamicNode(const Node: TDynamicNode; out Source: AnsiString);
    procedure SetCaption(const Value: AnsiString);
    function GetTransparent: Boolean;
    function IsActiveLinkNodeClicked: Boolean;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure SetAutoHeight(const Value: Boolean);
    procedure SetMarginHeight(const Value: Integer);
    procedure SetMarginWidth(const Value: Integer);
    procedure SetOffsetY(const Value: Integer);
    function GetOffsetY: Integer;
    function GetTextHeight: Integer;
  protected
    FNodeTree: TNodeTree;
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; x, y: Integer); override;
    procedure MouseMove(Shift: TShiftState; x, y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; x, y: Integer); override;
    procedure Resize; override;
    procedure DoLinkClicked(const LinkHref, LinkText: WideString); virtual;
    procedure DoDynamicTagInit(const AID: WideString; out Source: AnsiString); virtual;
    property Renderer: TDIHtmlRenderer read FRenderer;

    property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
    property OnDynamicTagInit: TDynamicTagInitEvent read FOnDynamicTagInit write FOnDynamicTagInit;
    property OnLinkClick: TLinkClickEvent read FOnLinkClick write FOnLinkClick;

    property Caption: AnsiString read FCaption write SetCaption;
    property Transparent: Boolean read GetTransparent write SetTransparent default False;
    property LinkColor: TColor read GetLinkColor write SetLinkColor default DIHTMLLABEL_DEFAULT_LINK_COLOR;
    property LinkColorClicked: TColor read GetLinkColorClicked write SetLinkColorClicked default DIHTMLLABEL_DEFAULT_LINK_COLOR_CLICKED;
    property LinkColorHot: TColor read GetLinkColorHot write SetLinkColorHot default DIHTMLLABEL_DEFAULT_LINK_COLOR_HOT;
    property LinkStyle: TFontStyles read GetLinkStyle write SetLinkStyle default DIHTMLLABEL_DEFAULT_LINK_STYLE;
    property HotLinks: Boolean read FHotLinks write FHotLinks default DIHTMLLABEL_DEFAULT_HOT_LINKS;
    property AutoHeight: Boolean read FAutoHeight write SetAutoHeight default DIHTMLLABEL_DEFAULT_AUTO_HEIGHT;
    property MarginWidth: Integer read FMarginWidth write SetMarginWidth default 0;
    property MarginHeight: Integer read FMarginHeight write SetMarginHeight default 0;
    property OffsetY: Integer read GetOffsetY write SetOffsetY default 0;
    property TextHeight: Integer read GetTextHeight;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetDynamicTagContents(const DynamicTagID: WideString): WideString;
    procedure Loaded; override;
    property NodeTree: TNodeTree read FNodeTree;
    procedure UpdateDynamicTag(const AID: WideString; const Source: AnsiString);
  end;

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

  TDIHtmlLabel = class(TDICustomHtmlLabel)
  public
    property TextHeight;
  published
    property Align;
    property Anchors;
    property AutoHeight;
    property Caption;
    property Color;
    property Constraints;
    property DragCursor;
    property DragMode;
    property Font;
    property HotLinks;
    property LinkColor;
    property LinkColorClicked;
    property LinkColorHot;
    property LinkStyle;
    property MarginHeight;
    property MarginWidth;
    property OffsetY;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Transparent;
    property Visible;
    property OnAfterPaint;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDynamicTagInit;
    property OnDragOver;
    property OnLinkClick;
    property OnStartDrag;
    property OnEndDrag;
    property OnMouseUp;
    property OnMouseDown;
    property OnMouseMove;
  end;

implementation

uses
  Forms;

{ ---------------------------------------------------------------------------- }
{ TDICustomHtmlLabel
{ ---------------------------------------------------------------------------- }

constructor TDICustomHtmlLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  Width := 65;
  Height := 17;

  FAutoHeight := DIHTMLLABEL_DEFAULT_AUTO_HEIGHT;
  FHotLinks := DIHTMLLABEL_DEFAULT_HOT_LINKS;

  FNodeTree := TNodeTree.Create;

  FRenderer := TDIHtmlRenderer.Create; ;
  FRenderer.LinkColor := DIHTMLLABEL_DEFAULT_LINK_COLOR;
  FRenderer.LinkColorClicked := DIHTMLLABEL_DEFAULT_LINK_COLOR_CLICKED;
  FRenderer.LinkColorHot := DIHTMLLABEL_DEFAULT_LINK_COLOR_HOT;
  FRenderer.LinkStyle := DIHTMLLABEL_DEFAULT_LINK_STYLE;
end;

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

destructor TDICustomHtmlLabel.Destroy;
begin
  FRenderer.Free;
  FNodeTree.Free;
  inherited Destroy;
end;

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

procedure TDICustomHtmlLabel.ActivateLinkNodeAtPos(const p: TPoint; State: TLinkState);
var
  NodeAtPoint: TLinkNode;

  function IsNewNode: Boolean;
  begin
    { We must only redraw the TLinkNode if it either isn't the same as the
      currently active TLinkNode (FActiveLinkNode), or if we're trying to change
      the state (that is, alter the color). }
    Result := (FActiveLinkNode <> NodeAtPoint);
    if not Result and Assigned(FActiveLinkNode) then
      Result := FActiveLinkNode.State <> State;
  end;

begin
  NodeAtPoint := TLinkNode(FNodeTree.GetNodeAtPointOfClass(p, TLinkNode));
  if (NodeAtPoint <> nil) and IsNewNode then
    begin
      DeactivateActiveLinkNode;
      NodeAtPoint.State := State;
      FActiveLinkNode := NodeAtPoint;
      FRenderer.RenderNode(Canvas, FRect, NodeAtPoint);
    end;
end;

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

procedure TDICustomHtmlLabel.CMFontChanged(var Message: TMessage);
begin
  inherited;
  SynchronizeRootAndFont;
  FNodeTree.ClearWordInfos;
  Invalidate;
end;

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

procedure TDICustomHtmlLabel.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FHotLinks and not IsActiveLinkNodeClicked then
    DeactivateActiveLinkNode;
end;

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

procedure TDICustomHtmlLabel.CMTextChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

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

procedure TDICustomHtmlLabel.DeactivateActiveLinkNode;
begin
  if FActiveLinkNode <> nil then
    try
      FActiveLinkNode.State := lsNormal;
      FRenderer.RenderNode(Canvas, FRect, FActiveLinkNode);
    finally
      FActiveLinkNode := nil;
    end;
end;

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

procedure TDICustomHtmlLabel.DoDynamicTagInit(const AID: WideString; out Source: AnsiString);
begin
  if Assigned(FOnDynamicTagInit) then FOnDynamicTagInit(Self, AID, Source);
end;

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

procedure TDICustomHtmlLabel.DoLinkClicked(const LinkHref, LinkText: WideString);
begin
  if Assigned(FOnLinkClick) then
    FOnLinkClick(Self, LinkHref, LinkText);
end;

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

function TDICustomHtmlLabel.GetDynamicTagContents(const DynamicTagID: WideString): WideString;
begin
  Result := FNodeTree.GetDynamicTagText(DynamicTagID);
end;

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

function TDICustomHtmlLabel.GetLinkColor: TColor;
begin
  Result := FRenderer.LinkColor;
end;

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

function TDICustomHtmlLabel.GetLinkColorClicked: TColor;
begin
  Result := FRenderer.LinkColorClicked;
end;

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

function TDICustomHtmlLabel.GetLinkColorHot: TColor;
begin
  Result := FRenderer.LinkColorHot;
end;

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

function TDICustomHtmlLabel.GetLinkStyle: TFontStyles;
begin
  Result := FRenderer.LinkStyle;
end;

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

function TDICustomHtmlLabel.GetTransparent: Boolean;
begin
  Result := not (csOpaque in ControlStyle);
end;

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

procedure TDICustomHtmlLabel.HandleDynamicNode(const Node: TDynamicNode; out Source: AnsiString);
begin
  if Node <> nil then
    DoDynamicTagInit(Node.ID, Source)
  else
    Source := '';
end;

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

function TDICustomHtmlLabel.IsActiveLinkNodeClicked: Boolean;
begin
  Result := FActiveLinkNode <> nil;
  if Result then
    Result := FActiveLinkNode.State = lsClicked;
end;

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

procedure TDICustomHtmlLabel.Loaded;
begin
  inherited;
  FOriginalCursor := Cursor;
  Resize;
end;

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

procedure TDICustomHtmlLabel.MouseDown(Button: TMouseButton; Shift: TShiftState; x, y: Integer);
begin
  inherited;
  ActivateLinkNodeAtPos(Point(x, y), lsClicked);
end;

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

procedure TDICustomHtmlLabel.MouseMove(Shift: TShiftState; x, y: Integer);
begin
  inherited;
  if FNodeTree.IsPointInNodeClass(Point(x, y), TLinkNode) then
    begin
      Cursor := crHandPoint;
      if FHotLinks and not IsActiveLinkNodeClicked then
        ActivateLinkNodeAtPos(Point(x, y), lsHot);
    end
  else
    begin
      Cursor := FOriginalCursor;
      if FHotLinks and not IsActiveLinkNodeClicked then
        DeactivateActiveLinkNode;
    end;
end;

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

procedure TDICustomHtmlLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; x, y: Integer);
var
  NodeAtPoint: TLinkNode;
begin
  inherited;
  if FNodeTree.IsPointInNodeClass(Point(x, y), TLinkNode) then
    begin
      NodeAtPoint := FNodeTree.GetNodeAtPointOfClass(Point(x, y), TLinkNode) as TLinkNode;
      if Assigned(NodeAtPoint) then
        DoLinkClicked(NodeAtPoint.Href, NodeAtPoint.Text);
    end;

  DeactivateActiveLinkNode;
end;

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

procedure TDICustomHtmlLabel.Paint;
begin
  inherited;
  if Assigned(FNodeTree) then
    begin
      with Canvas do
        begin
          if not Transparent then
            begin
              Brush.Color := Color;
              Brush.Style := bsSolid;
              FillRect(ClientRect);
            end;

          Brush.Style := bsClear;
        end;

      Canvas.Font := Font;
      FRenderer.RenderTree(Canvas, FRect, FNodeTree);

      if FAutoHeight and (Align in [alNone, alTop, alBottom]) then
        ClientHeight := FRenderer.TextHeight + FMarginHeight;
    end;
  if Assigned(FOnAfterPaint) then
    FOnAfterPaint(Self);
end;

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

procedure TDICustomHtmlLabel.Resize;
begin
  inherited;
  FRect := Rect(ClientRect.Left + FMarginWidth, ClientRect.Top + FMarginHeight,
    ClientRect.Right - FMarginWidth, ClientRect.Bottom);
end;

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

procedure TDICustomHtmlLabel.SetAutoHeight(const Value: Boolean);
begin
  if FAutoHeight <> Value then
    begin
      FAutoHeight := Value;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetCaption(const Value: AnsiString);
var
  Parser: TDefaultParser;
begin
  if FCaption <> Value then
    begin
      FCaption := Value;

      FActiveLinkNode := nil; // We're about to free the tree containing the node it's pointing to
      FNodeTree.Free;

      Parser := TDefaultParser.Create;
      Parser.DynamicNodeHandler := Self;
      FNodeTree := Parser.Parse(Value);
      Parser.Free;

      SynchronizeRootAndFont;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetLinkColor(const Value: TColor);
begin
  if FRenderer.LinkColor <> Value then
    begin
      FRenderer.LinkColor := Value;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetLinkColorClicked(const Value: TColor);
begin
  if FRenderer.LinkColorClicked <> Value then
    begin
      FRenderer.LinkColorClicked := Value;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetLinkColorHot(const Value: TColor);
begin
  if FRenderer.LinkColorHot <> Value then
    begin
      FRenderer.LinkColorHot := Value;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetLinkStyle(const Value: TFontStyles);
begin
  if FRenderer.LinkStyle <> Value then
    begin
      FRenderer.LinkStyle := Value;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetMarginHeight(const Value: Integer);
begin
  if FMarginHeight <> Value then
    begin
      FMarginHeight := Value;
      Resize;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetMarginWidth(const Value: Integer);
begin
  if FMarginWidth <> Value then
    begin
      FMarginWidth := Value;
      Resize;
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SetTransparent(const Value: Boolean);
begin
  if Transparent <> Value then
    begin
      if Value then
        ControlStyle := ControlStyle - [csOpaque]
      else
        ControlStyle := ControlStyle + [csOpaque];
      Invalidate;
    end;
end;

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

procedure TDICustomHtmlLabel.SynchronizeRootAndFont;
begin
  if Assigned(FNodeTree) then
    with FNodeTree.Root do
      begin
        Styles := Font.Style;
        Color := Font.Color;
      end;
end;

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

procedure TDICustomHtmlLabel.UpdateDynamicTag(const AID: WideString; const Source: AnsiString);
var
  NodeEnum: TTopLevelNodeEnumerator;
  Parser: TDefaultParser;
  Node: TDynamicNode;
begin
  NodeEnum := TTopLevelNodeEnumerator.Create;
  NodeEnum.RootNode := FNodeTree.Root;
  NodeEnum.NodeClass := TDynamicNode;

  Node := TDynamicNode(NodeEnum.NextNode);
  while (Node <> nil) and (Node.ID <> AID) do
    Node := TDynamicNode(NodeEnum.NextNode);
  NodeEnum.Free;

  if Node <> nil then
    begin
      Parser := TDefaultParser.Create;
      Parser.AddSourceTreeToDynamicNode(Node, Source);
      Paint;
    end;
end;

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

function TDICustomHtmlLabel.GetOffsetY: Integer;
begin
  Result := FRenderer.TextOffsetY;
end;

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

procedure TDICustomHtmlLabel.SetOffsetY(const Value: Integer);
begin
  if FRenderer.TextOffsetY <> Value then
    begin
      FRenderer.TextOffsetY := Value;
      Invalidate;
    end;
end;

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

function TDICustomHtmlLabel.GetTextHeight: Integer;
begin
  Result := FRenderer.TextHeight;
end;

end.