RtfLabel, Version 1.3b (alt)
Hinweis: dies ist nicht die neueste Version!
Datei: RtfLabel.pas
{ 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.3b - always find the most current version at http://flocke.vssd.de/prog/code/pascal/rtflabel/ Copyright (C) 2006, 2007 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 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; 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 LoadFromStream(Stream: TStream); procedure LoadFromFile(const Name: string); {$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_4_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 dc: HDC; pt: TPoint; begin 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 Assigned(FControl.FServices) then with FControl.FServices do begin Notify(TXTBIT_VIEWINSETCHANGE); TLabelTextServices(FControl.FServices).TxInvalidateRect(nil, True); end; FControl.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} 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.CMTextChanged(var Message: TMessage); begin inherited; UpdateText; end; procedure TCustomRtfLabel.DoAutoSize(w, h: Integer); begin if not (csReading in ComponentState) and FAutoSize and (h > 0) and Assigned(FPadding) then begin if w < 1 then w := 1; inc(h, MulDiv(FPadding.Top + FPadding.Bottom, FZoom, 100)); if FWordwrap then SetBounds(Left, Top, Width, h) else 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: string; begin Size := Stream.Size - Stream.Position; SetLength(Str, Size); Stream.ReadBuffer(Str[1], Size); Caption := 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 char; cap: string; begin if Assigned(FServices) then begin stx.flags := ST_DEFAULT; stx.codepage := CP_ACP; cap := 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 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); try rc := ClientRect; OleCheck(FServices.IServices.TxDraw(DVASPECT_CONTENT, -1, nil, nil, dc, 0, @rc, nil, @rc, nil, 0, TXTVIEW_ACTIVE)); finally 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. |