RtfLabel, Version 1.3d

{
  RtfLabel.pas

  VCL component using the windowless ITextServices interface of the windows
  richedit control version 3.0+ to implement a label that displays rich text.

  Version 1.3d - always find the most current version at
  http://flocke.vssd.de/prog/code/pascal/rtflabel/

  Copyright (C) 2006-2009 Volker Siebert <flocke@vssd.de>
  All rights reserved.

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation
  the rights to use, copy, modify, merge, publish, distribute, sublicense,
  and/or sell copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.
}

unit RtfLabel;

interface

{$I DelphiVersion.inc}
{$I Rich3Conf.inc}

uses
  Windows, Messages, ActiveX, SysUtils, Classes, Controls,
  RichEdit, RichEdit2, RichOle, RichTom, TextServ, DelphiTextServ;

type
  TCustomRtfLabel = class;

  TRtfLabelPadding = class(TPersistent)
  public
    FControl: TCustomRtfLabel;
    FPadding: array [0 .. 3] of Integer;
    FHiMetric: TRect;
    FUpdateCount: LongInt;
    FChanged: Boolean;
    function GetPad(Index: Integer): Integer;
    function GetRect: TRect;
    procedure SetPad(Index, Value: Integer);
    procedure SetRect(const Value: TRect);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure Changed;
    procedure UpdateControl;
  public
    constructor Create(AControl: TCustomRtfLabel);
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure EndUpdate;
    property Rect: TRect read GetRect write SetRect;
    property ViewInset: TRect read FHiMetric;
  published
    property Left: Integer index 0 read GetPad write SetPad default 0;
    property Top: Integer index 1 read GetPad write SetPad default 0;
    property Right: Integer index 2 read GetPad write SetPad default 0;
    property Bottom: Integer index 3 read GetPad write SetPad default 0;
  end;

  TCustomRtfLabel = class(TControl)
  private
    FAllowResize: Integer;
    FAutoSize: Boolean;
    {$IFNDEF DELPHI_4_UP}
    FOnResize: TNotifyEvent;
    {$ENDIF}
    FPadding: TRtfLabelPadding;
    FServices: TTextServices;
    FTransparentSet: Boolean;
    FWordWrap: Boolean;
    FZoom: Integer;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    function GetDocument: ITextDocument2;
    function GetTransparent: Boolean;
    procedure SetPadding(Value: TRtfLabelPadding);
    procedure SetTransparent(Value: Boolean);
    procedure SetWordWrap(Value: Boolean);
    procedure SetZoom(Value: Integer);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  protected
    procedure DoAutoSize(w, h: Integer);
    procedure ForceResize;
    procedure Resize;
      {$IFDEF DELPHI_4_UP} override; {$ELSE} dynamic; {$ENDIF}
    procedure SetAutoSize(Value: Boolean);
      {$IFDEF DELPHI_6_UP} override; {$ENDIF}
    procedure UpdateText;
    {$IFNDEF DELPHI_4_UP}
    property OnResize: TNotifyEvent read FOnResize write FOnResize;
    {$ENDIF}
    property TextServices: TTextServices read FServices;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadFromFile(const Name: string);
    procedure LoadFromStream(Stream: TStream);
    {$IFNDEF DELPHI_4_UP}
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    {$ENDIF}
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property Caption;
    property Document: ITextDocument2 read GetDocument;
    property Padding: TRtfLabelPadding read FPadding write SetPadding;
    property Transparent: Boolean read GetTransparent write SetTransparent
      stored FTransparentSet;
    property WordWrap: Boolean read FWordWrap write SetWordWrap default False;
    property Zoom: Integer read FZoom write SetZoom default 100;
  end;

  TRtfLabel = class(TCustomRtfLabel)
  published
    property Align;
    {$IFDEF DELPHI_4_UP}
    property Anchors;
    {$ENDIF}
    property AutoSize;
    {$IFDEF DELPHI_4_UP}
    property BiDiMode;
    {$ENDIF}
    property Caption;
    property Color nodefault;
    {$IFDEF DELPHI_4_UP}
    property Constraints;
    {$ENDIF}
    property DragCursor;
    {$IFDEF DELPHI_4_UP}
    property DragKind;
    {$ENDIF}
    property DragMode;
    property Enabled;
    property Font;
    property Padding;
    {$IFDEF DELPHI_4_UP}
    property ParentBiDiMode;
    {$ENDIF}
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Transparent;
    property Visible;
    property WordWrap;
    property Zoom;
    property OnClick;
    {$IFDEF DELPHI_5_UP}
    property OnContextPopup;
    {$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    {$IFDEF DELPHI_4_UP}
    property OnEndDock;
    {$ENDIF}
    property OnEndDrag;
    {$IFDEF DELPHI_9_UP}
    property OnMouseActivate;
    {$ENDIF}
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    {$IFDEF DELPHI_10_UP}
    property OnMouseEnter;
    property OnMouseLeave;
    {$ENDIF}
    property OnResize;
    {$IFDEF DELPHI_4_UP}
    property OnStartDock;
    {$ENDIF}
    property OnStartDrag;
  end;

procedure Register;

implementation

uses
  Graphics, ComObj,
  {$IFDEF DELPHI_9_UP} Themes, {$ENDIF}
  Forms, RichEditDll;

type
  TLabelTextServices = class(TTextServices)
  private
    FCharFormat: TCharFormatW;
    FControl: TCustomRtfLabel;
  protected
    // ITextHost interface
    function TxGetBackStyle(out style: TTxtBackStyle): HRESULT; override;
      stdcall;
    function TxGetCharFormat(out ppCF: PCharFormatW): HRESULT; override;
      stdcall;
    function TxGetClientRect(out rc: TRect): HRESULT; override; stdcall;
    function TxGetSysColor(nIndex: Integer): COLORREF; override; stdcall;
    function TxGetViewInset(out rc: TRect): HRESULT; override; stdcall;
    procedure TxInvalidateRect(prc: PRect; fMode: BOOL); override; stdcall;
    procedure TxViewChange(fUpdate: BOOL); override; stdcall;
    function TxNotify(iNotify: DWORD; pv: Pointer): HRESULT; override; stdcall;
  public
    constructor Create(AControl: TCustomRtfLabel);
    procedure FontChanged;
    procedure UpdateFont;
  end;

{ TLabelTextServices }

constructor TLabelTextServices.Create(AControl: TCustomRtfLabel);
begin
  FControl := AControl;
  inherited Create;
  SendMsg(EM_SETEVENTMASK, 0, ENM_REQUESTRESIZE);
  PropertyBits := TXTBIT_RICHTEXT or TXTBIT_MULTILINE;
  if RichEditVersion >= rvRichEdit4 then
    SendMsg(EM_SETTYPOGRAPHYOPTIONS,
      TO_ADVANCEDTYPOGRAPHY or TO_ADVANCEDLAYOUT,
      TO_ADVANCEDTYPOGRAPHY or TO_ADVANCEDLAYOUT);
  SendMsg(EM_AUTOURLDETECT, 0, 0);
end;

procedure TLabelTextServices.FontChanged;
begin
  UpdateFont;
  Notify(TXTBIT_CHARFORMATCHANGE);
end;

function TLabelTextServices.TxGetBackStyle(out style: TTxtBackStyle): HRESULT;
begin
  if FControl.Transparent then
    style := TXTBACK_TRANSPARENT
  else
    style := TXTBACK_OPAQUE;
  Result := S_OK;
end;

function TLabelTextServices.TxGetCharFormat(out ppCF: PCharFormatW): HRESULT;
begin
  ppCF := @FCharFormat;
  Result := S_OK;
end;

function TLabelTextServices.TxGetClientRect(out rc: TRect): HRESULT;
begin
  rc := FControl.ClientRect;
  Result := S_OK;
end;

function TLabelTextServices.TxGetSysColor(nIndex: Integer): COLORREF;
begin
  if nIndex = COLOR_WINDOW then
    Result := ColorToRGB(FControl.Color)
  else if nIndex = COLOR_WINDOWTEXT then
    Result := ColorToRGB(FControl.Font.Color)
  else
    Result := GetSysColor(nIndex);
end;

function TLabelTextServices.TxGetViewInset(out rc: TRect): HRESULT;
begin
  rc := FControl.FPadding.ViewInset;
  Result := S_OK;
end;

procedure TLabelTextServices.TxInvalidateRect(prc: PRect; fMode: BOOL);
begin
  FControl.Invalidate;
end;

function TLabelTextServices.TxNotify(iNotify: DWORD; pv: Pointer): HRESULT;
begin
  if iNotify = EN_REQUESTRESIZE then
    with PReqSize(pv)^.rc do
      FControl.DoAutoSize(Right - Left, Bottom - Top);
  Result := S_OK;
end;

procedure TLabelTextServices.TxViewChange(fUpdate: BOOL);
begin
  if fUpdate then
    FControl.Update;
end;

procedure TLabelTextServices.UpdateFont;
var
  FontName: WideString;
begin
  FillChar(FCharFormat, SizeOf(FCharFormat), 0);
  FCharFormat.cbSize := SizeOf(FCharFormat);
  FCharFormat.dwMask := Integer(CFM_ALL);
  if fsBold in FControl.Font.Style then
    FCharFormat.dwEffects := FCharFormat.dwEffects or CFE_BOLD;
  if fsItalic in FControl.Font.Style then
    FCharFormat.dwEffects := FCharFormat.dwEffects or CFE_ITALIC;
  if fsUnderline in FControl.Font.Style then
    FCharFormat.dwEffects := FCharFormat.dwEffects or CFE_UNDERLINE;
  FCharFormat.yHeight := 20 * FControl.Font.Size;
  FCharFormat.crTextColor := ColorToRGB(FControl.Font.Color);
  if FControl.Font.Color = clWindowText then
    FCharFormat.dwEffects := FCharFormat.dwEffects or CFE_AUTOCOLOR;
  FCharFormat.bCharSet := FControl.Font.Charset;
  FCharFormat.bPitchAndFamily := DEFAULT_PITCH;
  FontName := FControl.Font.Name;
  LStrCpyW(FCharFormat.szFaceName, PWideChar(FontName));
end;

{ TRtfLabelPadding }

constructor TRtfLabelPadding.Create(AControl: TCustomRtfLabel);
begin
  inherited Create;
  FControl := AControl;
end;

procedure TRtfLabelPadding.Assign(Source: TPersistent);
begin
  if Source is TRtfLabelPadding then
    Rect := TRtfLabelPadding(Source).Rect
  else
    inherited;
end;

procedure TRtfLabelPadding.AssignTo(Dest: TPersistent);
begin
  if Dest is TRtfLabelPadding then
    Dest.Assign(Self)
  else
    inherited;
end;

procedure TRtfLabelPadding.BeginUpdate;
begin
  inc(FUpdateCount);
end;

procedure TRtfLabelPadding.Changed;
begin
  if FUpdateCount > 0 then
    FChanged := True
  else
    UpdateControl;
end;

procedure TRtfLabelPadding.EndUpdate;
begin
  if FUpdateCount > 0 then
  begin
    dec(FUpdateCount);
    if FUpdateCount = 0 then
    begin
      if FChanged then
      begin
        FChanged := False;
        UpdateControl;
      end;
    end;
  end;
end;

function TRtfLabelPadding.GetPad(Index: Integer): Integer;
begin
  Result := FPadding[Index and 3];
end;

function TRtfLabelPadding.GetRect: TRect;
begin
  with Result do
  begin
    Left   := FPadding[0];
    Top    := FPadding[1];
    Right  := FPadding[2];
    Bottom := FPadding[3];
  end;
end;

procedure TRtfLabelPadding.SetPad(Index, Value: Integer);
begin
  if FPadding[Index and 3] <> Value then
  begin
    FPadding[Index and 3] := Value;
    Changed;
  end;
end;

procedure TRtfLabelPadding.SetRect(const Value: TRect);
begin
  BeginUpdate;
  try
    Left   := Value.Left;
    Top    := Value.Top;
    Right  := Value.Right;
    Bottom := Value.Bottom;
  finally
    EndUpdate;
  end;
end;

procedure TRtfLabelPadding.UpdateControl;
var
  ctl: TCustomRtfLabel;
  dc: HDC;
  pt: TPoint;
begin
  ctl := FControl as TCustomRtfLabel;

  dc := GetDC(Application.Handle);
  try
    pt.X := GetDeviceCaps(dc, LOGPIXELSX);
    pt.Y := GetDeviceCaps(dc, LOGPIXELSY);
  finally
    ReleaseDC(Application.Handle, dc);
  end;

  FHiMetric.Left   := MulDiv(FPadding[0], 2540, pt.X);
  FHiMetric.Top    := MulDiv(FPadding[1], 2540, pt.Y);
  FHiMetric.Right  := MulDiv(FPadding[2], 2540, pt.X);
  FHiMetric.Bottom := MulDiv(FPadding[3], 2540, pt.Y);

  if ctl.FServices <> nil then
    with TLabelTextServices(ctl.FServices) do
    begin
      Notify(TXTBIT_VIEWINSETCHANGE);
      TxInvalidateRect(nil, True);
    end;

  ctl.ForceResize;
end;

{ TCustomRtfLabel }

constructor TCustomRtfLabel.Create(AOwner: TComponent);
begin
  inherited;

  {$IFDEF DELPHI_9_UP}
  if ThemeServices.ThemesEnabled then
    ControlStyle := ControlStyle - [csOpaque]
  else
    ControlStyle := ControlStyle + [csOpaque];
  {$ENDIF}

  FAllowResize := -1;
  FPadding := TRtfLabelPadding.Create(Self);
  FServices := TLabelTextServices.Create(Self);

  ControlStyle := ControlStyle + [csReplicatable];
  Width := 65;
  Height := 17;
  FAutoSize := True;
  FZoom := 100;

  TLabelTextServices(FServices).UpdateFont;
end;

destructor TCustomRtfLabel.Destroy;
begin
  if FServices <> nil then
  begin
    FServices.Free;
    FServices := nil;
  end;
  if FPadding <> nil then
  begin
    FPadding.Free;
    FPadding := nil;
  end;
  inherited;
end;

procedure TCustomRtfLabel.CMColorChanged(var Message: TMessage);
begin
  if Assigned(FServices) then
  begin
    FServices.SendMsg(WM_SYSCOLORCHANGE, 0, 0);
    Invalidate;
  end;
  inherited;
end;

procedure TCustomRtfLabel.CMFontChanged(var Message: TMessage);
begin
  inherited;
  if Assigned(FServices) then
  begin
    TLabelTextServices(FServices).FontChanged;
    UpdateText;
  end;
end;

procedure TCustomRtfLabel.CMSysColorChange(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TCustomRtfLabel.CMTextChanged(var Message: TMessage);
begin
  inherited;
  UpdateText;
end;

procedure TCustomRtfLabel.DoAutoSize(w, h: Integer);
var
  Delta: TRect;
begin
  if not (csReading in ComponentState) and FAutoSize and (h > 0)
    and Assigned(FPadding) then
  begin
    if FAllowResize = 0 then
    begin
      OutputDebugString('DoAutoSize:FAllowResize=0');
      Exit;
    end;
    if FAllowResize > 0 then
      Dec(FAllowResize);

    if w < 1 then
      w := 1;
    inc(h, MulDiv(FPadding.Top + FPadding.Bottom, FZoom, 100));

    Delta := ClientRect;
    Inc(w, Width - Delta.Right);
    Inc(h, Height - Delta.Bottom);

    if (not FWordWrap) and (w = Width + 1) then
      w := Width;

    if FWordwrap then
      SetBounds(Left, Top, Width, h)
    else if (w <> Width) or (h <> Height) then
      SetBounds(Left, Top, w, h);
  end;
end;

procedure TCustomRtfLabel.ForceResize;
begin
  if FAutoSize and Assigned(FServices) then
    FServices.SendMsg(EM_REQUESTRESIZE, 0, 0);
end;

function TCustomRtfLabel.GetDocument: ITextDocument2;
begin
  Result := FServices.IDocument;
end;

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

procedure TCustomRtfLabel.LoadFromFile(const Name: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(Name, fmOpenRead or fmShareDenyNone);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TCustomRtfLabel.LoadFromStream(Stream: TStream);
var
  Size: LongInt;
  Str: AnsiString;  // Assuming RTF is ANSI
begin
  Size := Stream.Size - Stream.Position;
  SetLength(Str, Size);
  Stream.ReadBuffer(Str[1], Size);
  Caption := string(Str);
end;

procedure TCustomRtfLabel.Resize;
begin
  {$IFDEF DELPHI_4_UP}
  inherited;
  {$ELSE}
  if Assigned(FOnResize) then
    FOnResize(Self);
  {$ENDIF}
  if Assigned(FServices) and not FAutoSize then
    FServices.Notify(TXTBIT_CLIENTRECTCHANGE);
end;

procedure TCustomRtfLabel.SetAutoSize(Value: Boolean);
begin
  if Value <> FAutoSize then
  begin
    FAutoSize := Value;
    ForceResize;
  end;
end;

{$IFNDEF DELPHI_4_UP}
procedure TCustomRtfLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited;
  if not (csLoading in ComponentState) then
    Resize;
end;
{$ENDIF}

procedure TCustomRtfLabel.SetPadding(Value: TRtfLabelPadding);
begin
  if Assigned(FPadding) then
    FPadding.Assign(Value);
end;

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

  if Changed or not FTransparentSet then
  begin
    FTransparentSet := True;
    if Assigned(FServices) then
      FServices.Notify(TXTBIT_BACKSTYLECHANGE);
  end;
end;

procedure TCustomRtfLabel.SetWordWrap(Value: Boolean);
begin
  if Value <> FWordWrap then
  begin
    FWordWrap := Value;
    Invalidate;
    if Assigned(FServices) then
      with FServices do
      begin
        if Value then
          PropertyBits := PropertyBits or TXTBIT_WORDWRAP
        else
          PropertyBits := PropertyBits and not TXTBIT_WORDWRAP;
        ForceResize;
      end;
  end;
end;

procedure TCustomRtfLabel.SetZoom(Value: Integer);
begin
  if Value = 0 then
    Value := 100
  else if Value < 2 then
    Value := 2
  else if Value > 6400 then
    Value := 6400;

  if Value <> FZoom then
  begin
    FZoom := Value;
    if FZoom = 100 then
      FServices.SendMsg(EM_SETZOOM, 0, 0)
    else
      FServices.SendMsg(EM_SETZOOM, FZoom, 100);
  end;
end;

procedure TCustomRtfLabel.UpdateText;
var
  stx: TSetTextEx;
  chs: array [0 .. 1] of AnsiChar;
  cap: AnsiString;
begin
  if Assigned(FServices) then
  begin
    stx.flags := ST_DEFAULT;
    stx.codepage := CP_ACP;
    cap := AnsiString(Caption);
    try
      FServices.SendMsg(EM_SETTEXTEX, LongInt(@stx), Integer(@cap[1]));
    except
      // Assume incorrect RTF
      chs[0] := cap[1];
      chs[1] := #0;
      FServices.SendMsg(EM_SETTEXTEX, LongInt(@stx), Integer(@chs[0]));
      if cap[1] <> #0 then
      begin
        stx.flags := ST_DEFAULT or ST_SELECTION;
        FServices.SendMsg(EM_SETTEXTEX, LongInt(@stx), Integer(@cap[2]));
      end;
    end;

    if FZoom <> 100 then
      FServices.SendMsg(EM_SETZOOM, FZoom, 100);
  end;
end;

procedure TCustomRtfLabel.WMPaint(var Message: TWMPaint);
var
  dc: HDC;
  rc: TRect;
  pt, pt2: TPoint;
begin
  if FAllowResize >= 0 then
    Exit;

  dc := Message.DC;
  if (dc <> 0) and Assigned(FServices) then
  begin
    { For non TWinControl controls, Delphi moves the DC's window origin, but
      RichEdit doesn't seem to like moved window origins. So we reset the
      window origin and instead move the viewport origin (by that amount).
    }
    SetWindowOrgEx(dc, 0, 0, @pt);
    OffsetViewportOrgEx(dc, -pt.x, -pt.y, pt2);
    FAllowResize := 1;
    try
      rc := ClientRect;
      OleCheck(FServices.IServices.TxDraw(DVASPECT_CONTENT, -1, nil, nil, dc,
        0, @rc, nil, @rc, nil, 0, TXTVIEW_ACTIVE));
    finally
      FAllowResize := -1;
      SetViewportOrgEx(dc, pt2.x, pt2.y, nil);
      SetWindowOrgEx(dc, pt.x, pt.y, nil);
    end;
  end;
end;

{------------------------------------------------------------}
{ Register }

procedure Register;
begin
  RegisterComponents('Flocke', [TRtfLabel]);
end;

end.