{
RtfLabel_Caption_Editor.pas
Design time editor form for the TRtfLabel.Caption property. Since we may
put a whole RTF document into this, it is no longer displayed directly in the
property inspector but can be edited in a seperate form.
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_Caption_Editor;
interface
{$I DelphiVersion.inc}
{$I Rich3Conf.inc}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Menus,
{$IFDEF DELPHI_6_UP}
DesignEditors, DesignIntf,
{$ELSE}
DsgnIntf,
{$ENDIF}
RtfLabel;
type
TRtfLabel_Caption_Editor = class(TStringProperty)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
function GetValue: string; override;
procedure SetValue(const Value: string); override;
end;
procedure Register;
implementation
const
CBorder = 8;
var
Last_Bounds: TRect;
Last_Filter: Integer;
{ TForm_RtfLabel_Caption }
resourcestring
{$IFDEF LANG_GERMAN}
{$DEFINE LANG_DEFINED}
SCaption = 'RTF';
SButtonOpen = 'Öffnen...';
SButtonOk = 'OK';
SButtonCancel = 'Abbrechen';
SOpenFilter = 'RTF-Dateien (*.rtf)|*.rtf|Textdateien (*.txt)|*.txt|Alle Dateien|*.*';
SOpenCaption = 'RTF-Datei öffnen';
SContainsRtf = '(RTF)';
SContainsText = '(Text)';
SIsEmpty = '(Leer)';
{$ENDIF}
{$IFNDEF LANG_DEFINED}
SCaption = 'RTF';
SButtonOpen = 'Open...';
SButtonOk = 'OK';
SButtonCancel = 'Cancel';
SOpenFilter = 'RTF files (*.rtf)|*.rtf|Text files (*.txt)|*.txt|All files|*.*';
SOpenCaption = 'Open RTF file';
SContainsRtf = '(RTF)';
SContainsText = '(Text)';
SIsEmpty = '(Empty)';
{$ENDIF}
type
TForm_RtfLabel_Caption = class(TForm)
private
FGripRect: TRect;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
public
Memo1: TMemo;
Button1: TButton;
Button2: TButton;
Button3: TButton;
OpenDialog1: TOpenDialog;
constructor Create(AOwner: TComponent); override;
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormPaint(Sender: TObject);
end;
procedure TForm_RtfLabel_Caption.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
end;
constructor TForm_RtfLabel_Caption.Create(AOwner: TComponent);
begin
try
inherited;
except
on E: EResNotFound do
begin
// Ist ok ;)
end
else
raise;
end;
Memo1 := TMemo.Create(Self);
with Memo1 do
begin
Parent := Self;
Left := 8;
Top := 8;
Font.Name := 'Courier New';
Font.Size := 9;
MaxLength := 10000000;
ScrollBars := ssBoth;
WordWrap := False;
end;
Button1 := TButton.Create(Self);
with Button1 do
begin
Parent := Self;
Left := 8;
Width := 73;
Height := 25;
Caption := SButtonOpen;
OnClick := Button1Click;
end;
Button2 := TButton.Create(Self);
with Button2 do
begin
Parent := Self;
Width := 73;
Height := 25;
Caption := SButtonOk;
Default := True;
ModalResult := mrOk;
end;
Button3 := TButton.Create(Self);
with Button3 do
begin
Parent := Self;
Width := 73;
Height := 25;
Caption := SButtonCancel;
Cancel := True;
ModalResult := mrCancel;
end;
OpenDialog1 := TOpenDialog.Create(Self);
with OpenDialog1 do
begin
Parent := Self;
DefaultExt := 'rtf';
Filter := SOpenFilter;
Options := [ofHideReadOnly, ofFileMustExist];
Title := SOpenCaption;
end;
OnCreate := FormCreate;
OnHide := FormHide;
OnPaint := FormPaint;
OnResize := FormResize;
OnShow := FormShow;
Left := 240;
Top := 180;
ClientWidth := 425;
ClientHeight := 290;
Caption := SCaption;
end;
procedure TForm_RtfLabel_Caption.FormCreate(Sender: TObject);
begin
if Screen.Fonts.IndexOf('Tahoma') >= 0 then
Font.Name := 'Tahoma';
{$IFDEF DELPHI_4_UP}
Constraints.MinWidth := 320 + (Width - ClientWidth);
Constraints.MinHeight := 200 + (Height - ClientHeight);
{$ENDIF}
end;
procedure TForm_RtfLabel_Caption.FormHide(Sender: TObject);
begin
Last_Bounds := BoundsRect;
Last_Filter := OpenDialog1.FilterIndex;
end;
procedure TForm_RtfLabel_Caption.FormPaint(Sender: TObject);
begin
DrawFrameControl(Canvas.Handle, FGripRect, DFC_SCROLL, DFCS_SCROLLSIZEGRIP);
end;
procedure TForm_RtfLabel_Caption.FormResize(Sender: TObject);
begin
if HandleAllocated and not IsRectEmpty(FGripRect) then
InvalidateRect(Handle, @FGripRect, True);
FGripRect := ClientRect;
{$IFDEF DELPHI_4_UP}
if UseRightToLeftScrollBar then
FGripRect.Right := FGripRect.Left + GetSystemMetrics(SM_CXVSCROLL)
else
{$ENDIF}
FGripRect.Left := FGripRect.Right - GetSystemMetrics(SM_CXVSCROLL);
FGripRect.Top := FGripRect.Bottom - GetSystemMetrics(SM_CYHSCROLL);
if HandleAllocated and not IsRectEmpty(FGripRect) then
InvalidateRect(Handle, @FGripRect, True);
Button3.Left := ClientWidth - CBorder - Button3.Width;
Button3.Top := ClientHeight - CBorder - Button3.Height;
Button2.Top := Button3.Top;
Button2.Left := Button3.Left - CBorder - Button2.Width;
Button1.Top := Button3.Top;
Memo1.Width := ClientWidth - Memo1.Left - CBorder;
Memo1.Height := Button3.Top - CBorder - Memo1.Top;
end;
procedure TForm_RtfLabel_Caption.FormShow(Sender: TObject);
begin
if Last_Bounds.Right > Last_Bounds.Left then
begin
BoundsRect := Last_Bounds;
OpenDialog1.FilterIndex := Last_Filter;
end;
end;
procedure TForm_RtfLabel_Caption.WMNCHitTest(var Message: TWMNCHitTest);
var
pt: TPoint;
begin
with Message do
pt := ScreenToClient(Point(XPos, YPos));
if not PtInRect(FGripRect, pt) then
inherited
{$IFDEF DELPHI_4_UP}
else if UseRightToLeftScrollBar then
Message.Result := HTBOTTOMLEFT
{$ENDIF}
else
Message.Result := HTBOTTOMRIGHT;
end;
{ TRtfLabel_Caption_Editor }
procedure TRtfLabel_Caption_Editor.Edit;
begin
with TForm_RtfLabel_Caption.Create(Application) do
try
Memo1.Lines.Text := GetStrValue;
if ShowModal = mrOk then
SetStrValue(Memo1.Lines.Text);
finally
Free;
end;
end;
function TRtfLabel_Caption_Editor.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paDialog];
end;
function TRtfLabel_Caption_Editor.GetValue: string;
var
str: string;
begin
str := Copy(GetStrValue, 1, 5);
if str = '{\rtf' then
Result := SContainsRtf
else if str <> '' then
Result := SContainsText
else
Result := SIsEmpty;
end;
procedure TRtfLabel_Caption_Editor.SetValue(const Value: string);
begin
if Value = '' then
SetStrValue('');
end;
{ Register }
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TCaption), TRtfLabel, 'Caption',
TRtfLabel_Caption_Editor);
end;
end. |