{
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. |