TRichEdit

Code:

{....}

protected

   procedure WndProc(var Message: TMessage); override;

{....}

uses Richedit, ShellApi;

{Today I want to show how to implement URL highlighting and URL navigation

without any third-party components. This functionality is implemented in

RichEdit from Microsoft (and MS Outlook use this feature, for example) and

only Borland's developers didn't publish it for us.}

procedure TForm1.FormCreate(Sender: TObject);

var

mask: Word;

begin

mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);

SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);

SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);

//Some text in RichEdit

RichEdit1.Text := 'Scalabium Software'#13#10 +

   ' Site is located at www.scalabium.com. Welcome to our site.';

end;

procedure TForm1.WndProc(var Message: TMessage);

var

p: TENLink;

strURL: string;

begin

if (Message.Msg = WM_NOTIFY) then

begin

   if (PNMHDR(Message.lParam).code = EN_LINK) then

   begin

     p := TENLink(Pointer(TWMNotify(Message).NMHdr)^);

     if (p.Msg = WM_LBUTTONDOWN) then

     begin

       SendMessage(RichEdit1.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));

       strURL := RichEdit1.SelText;

       ShellExecute(Handle, 'open', PChar(strURL), 0, 0, SW_SHOWNORMAL);

     end

   end

end;

inherited;

end;

Code:

var

pt: TPoint;

begin

with richedit1 do begin

   Perform( messages.EM_POSFROMCHAR, WPARAM(@pt), selstart );

   label1.caption := Format('(%d,%d)', [pt.x, pt.y]);

end;

end;

var

r: LongInt;

begin

with memo1 do begin

   r := Perform( messages.EM_POSFROMCHAR, selstart, 0);

   if r >= 0 then begin

     label1.caption := IntToStr(HiWord(r));

     label2.caption := IntToStr(LoWord(r));

   end;

end;

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

{©Drkb v.3: www.drkb.ru,

®Vit (Vitaly Nevzorov) - Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.}

var t:TFileStream;

begin

t:=TFileStream.create('c:\myfilename.txt', fmCreate or fmOpenWrite);

t.Size:=0;

RxRichEdit1.Lines.SaveToStream(t);

t.free;

end;

Code:

function GetRTFText(ARichEdit: TRichedit): string;

var

  ss: TStringStream;

  emptystr: string;

begin

  emptystr := '';

  ss := TStringStream.Create(emptystr);

  try

    ARichEdit.PlainText := False;

    ARichEdit.Lines.SaveToStream(ss);

    Result := ss.DataString;

  finally

    ss.Free

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  Memo1.Text := GetRTFText(RichEdit1);

end;

Code:

{

You have to dig into the Rich Text Format if you want to copy text to the

clipboard that has format information embedded. The application you paste

this text into has to understand RTF, or the formatting will not show up.

OK, the first step is to register a clipboard format for RTF, since this is

not a predefined format:

}

Var

CF_RTF : Word;

CF_RTF := RegisterClipboardFormat('Rich Text Format');

{

The format name has to appear as typed above, this is the name used by MS

Word for Windows and similar MS products.

NOTE: The Richedit Unit declares a constant CF_RTF, which is NOT the

clipboard format handle but the string you need to pass to RegisterClipboard

format! So you can place Richedit into your uses clause and change the line

above to

}

CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF);

{

The next step is to build a RTF string with the embedded format information.

You will get a shock if you inspect the mess of RTF stuff W4W will put into

the clipboard if you copy just a few characters (the app below allows you to

inspect the clipboard), but you can get away with a lot less. The bare

minimum would be something like this (inserts an underlined 44444):

}

const

testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';

{

The correct balance of opening and closing braces is extremely important, one

mismatch and the target app will not be able to interpret the text

correctly. If you want to control the font used for the pasted text you need

to add a fonttable (the default font is Tms Rmn, not the active font in the

target app!). See example app below, testtext2. If you want more info, the

full RTF specs can be found on www.microsoft.com, a subset is also described

in the Windows help compiler docs (hcw.hlp, comes with Delphi).

}

unit Clipfmt1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

   MemFormats: TMemo;

   label1: TLabel;

   BtnShowFormats: TButton;

   BtnGetRTF: TButton;

   BtnSetRTF: TButton;

   MemExample: TMemo;

   procedure FormCreate(Sender: TObject);

   procedure BtnShowFormatsClick(Sender: TObject);

   procedure BtnGetRTFClick(Sender: TObject);

   procedure BtnSetRTFClick(Sender: TObject);

private

public

   CF_RTF: Word;

end;

var

Form1: TForm1;

implementation

uses Clipbrd;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

// register clipboard format rtf

CF_RTF := RegisterClipboardFormat('Rich Text Format');

if CF_RTF = 0 then

begin

   ShowMessage('Unable to register the Rich Text clipboard format!');

   Application.Terminate;

end;

BtnShowFormats.Click;

end;

// show clipboard formats

procedure TForm1.BtnShowFormatsClick(Sender: TObject);

var

buf: array [0..60] of Char;

n: Integer;

fmt: Word;

Name: string[30];

begin

MemFormats.Clear;

for n := 0 to Clipboard.FormatCount - 1 do

begin

   fmt := Clipboard.Formats[n];

   if GetClipboardFormatName(fmt, buf, Pred(SizeOf(buf))) <> 0 then

     MemFormats.Lines.Add(StrPas(buf))

   else

   begin

     case fmt of

       1: Name := 'CF_TEXT';

       2: Name := 'CF_BITMAP';

       3: Name := 'CF_METAFILEPICT';

       4: Name := 'CF_SYLK';

       5: Name := 'CF_DIF';

       6: Name := 'CF_TIFF';

       7: Name := 'CF_OEMTEXT';

       8: Name := 'CF_DIB';

       9: Name := 'CF_PALETTE';

       10: Name := 'CF_PENDATA';

       11: Name := 'CF_RIFF';

       12: Name := 'CF_WAVE';

       13: Name := 'CF_UNICODETEXT';

       14: Name := 'CF_ENHMETAFILE';

       15: Name := 'CF_HDROP (Win 95)';

       16: Name := 'CF_LOCALE (Win 95)';

       17: Name := 'CF_MAX (Win 95)';

       $0080: Name := 'CF_OWNERDISPLAY';

       $0081: Name := 'CF_DSPTEXT';

       $0082: Name := 'CF_DSPBITMAP';

       $0083: Name := 'CF_DSPMETAFILEPICT';

       $008E: Name := 'CF_DSPENHMETAFILE';

       $0200..$02FF: Name := 'private format';

       $0300..$03FF: Name := 'GDI object';

       else

         Name := 'unknown format';

     end;

     MemFormats.Lines.Add(Name);

   end;

end;

end;

// get rtf code from clipboard

procedure TForm1.BtnGetRTFClick(Sender: TObject);

var

MemHandle: THandle;

begin

with Clipboard do

begin

   Open;

   try

     if HasFormat(CF_RTF) then

     begin

       MemHandle := GetAsHandle(CF_RTF);

       MemExample.SetTextBuf(GlobalLock(MemHandle));

       GlobalUnlock(MemHandle);

     end

     else

       MessageDlg('The clipboard contains no RTF text!',

         mtError, [mbOK], 0);

   finally

     Close;

   end;

end;

end;

// set rtf code to the clipboard

procedure TForm1.BtnSetRTFClick(Sender: TObject);

const

testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';

testtext2: PChar = '{\rtf1\ansi' +

   '\deff4\deflang1033{\fonttbl{\f4\froman\fcharset0\fprq2 Times New Roman;}}' +

   '\pard\plain 12{\ul 44444}}';

flap: Boolean = False;

var

MemHandle: THandle;

rtfstring: PChar;

begin

with Clipboard do

begin

   if flap then

     rtfstring := testtext2

   else

     rtfstring := testtext;

   flap := not flap;

   MemHandle := GlobalAlloc(GHND or GMEM_SHARE, StrLen(rtfstring) + 1);

   if MemHandle <> 0 then

   begin

     StrCopy(GlobalLock(MemHandle), rtfstring);

     GlobalUnlock(MemHandle);

     Open;

     try

       AsText := '1244444';

       SetAsHandle(CF_RTF, MemHandle);

     finally

       Close;

     end;

   end

   else

     MessageDlg('Global Alloc failed!',

       mtError, [mbOK], 0);

end;

end;

end.

Code:

uses

RichEdit;

procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);

var

Format: CHARFORMAT2;

begin

FillChar(Format, SizeOf(Format), 0);

with Format do

begin

   cbSize := SizeOf(Format);

   dwMask := CFM_BACKCOLOR;

   crBackColor := AColor;

   Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));

end;

end;

// Example: Set clYellow background color for the selected text.

procedure TForm1.Button1Click(Sender: TObject);

begin

RE_SetSelBgColor(RichEdit1, clYellow);

end;

Code:

unit dbrich;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComCtrls, DB, DBTables, Menus, ExtCtrls, Mask, Buttons, DBCtrls;

//Замечание: вызывать Tablex.Edit необходимо перед изменением свойства paragraph

type

TDBRichEdit = class(TRichEdit)

private

   FDataLink: TFieldDataLink;

   FAutoDisplay: Boolean;

   FFocused: Boolean;

   FMemoLoaded: Boolean;

   FPaintControl: TPaintControl;

   procedure DataChange(Sender: TObject);

   procedure EditingChange(Sender: TObject);

   function GetDataField: string;

   function GetDataSource: TDataSource;

   function GetField: TField;

   function GetReadOnly: Boolean;

   procedure SetDataField(const Value: string);

   procedure SetDataSource(Value: TDataSource);

   procedure SetReadOnly(Value: Boolean);

   procedure SetAutoDisplay(Value: Boolean);

   procedure SetFocused(Value: Boolean);

   procedure UpdateData(Sender: TObject);

   procedure WMCut(var Message: TMessage); message WM_CUT;

   procedure WMPaste(var Message: TMessage); message WM_PASTE;

   procedure CMEnter(var Message: TCMEnter); message CM_ENTER;

   procedure CMExit(var Message: TCMExit); message CM_EXIT;

   procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);

     message WM_LBUTTONDBLCLK;

   procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

   procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;

protected

   procedure Change; override;

   procedure KeyDown(var Key: Word; Shift: TShiftState); override;

   procedure KeyPress(var Key: Char); override;

   procedure Notification(AComponent: TComponent;

     Operation: TOperation); override;

   procedure WndProc(var Message: TMessage); override;

public

   constructor Create(AOwner: TComponent); override;

   destructor Destroy; override;

   procedure LoadMemo;

   property   Field: TField read GetField;

published

   property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay

     default True;

   property DataField: string read GetDataField write SetDataField;

   property DataSource: TDataSource read GetDataSource write SetDataSource;

   property ReadOnly: Boolean read GetReadOnly write SetReadOnly

     default False;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Data Controls', [TDBRichEdit]);

end;

{Mostly copied from DBMemo}

constructor TDBRichEdit.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

inherited ReadOnly := True;

FAutoDisplay := True;

FDataLink := TFieldDataLink.Create;

FDataLink.Control := Self;

FDataLink.OnDataChange := DataChange;

FDataLink.OnEditingChange := EditingChange;

FDataLink.OnUpdateData := UpdateData;

FPaintControl := TPaintControl.Create(Self, 'EDIT');

end;

destructor TDBRichEdit.Destroy;

begin

FPaintControl.Free;

FDataLink.Free;

FDataLink := nil;

inherited Destroy;

end;

procedure TDBRichEdit.Notification(AComponent: TComponent;

Operation: TOperation);

begin

inherited Notification(AComponent, Operation);

if (Operation = opRemove) and (FDataLink <> nil) and

   (AComponent = DataSource) then DataSource := nil;

end;

procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);

begin

inherited KeyDown(Key, Shift);

if FMemoLoaded then

begin

   if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then

     FDataLink.Edit;

end else

   Key := 0;

end;

procedure TDBRichEdit.KeyPress(var Key: Char);

begin

inherited KeyPress(Key);

if FMemoLoaded then

begin

   if (Key in [#32..#255]) and (FDataLink.Field <> nil) and

     not FDataLink.Field.IsValidChar(Key) then

   begin

     MessageBeep(0);

     Key := #0;

   end;

   case Key of

     ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:

       FDataLink.Edit;

     #27:

       FDataLink.Reset;

   end;

end else

begin

   if Key = #13 then LoadMemo;

   Key := #0;

end;

end;

procedure TDBRichEdit.Change;

begin

with FdataLink do

begin

   {if Assigned(FdataLink) and (Assigned(DataSource))and

    (DataSource.State = dsBrowse) then

     Edit; } {make sure edits on Attributes change}

   if FMemoLoaded then Modified;

end;

FMemoLoaded := True;

inherited Change;

end;

function TDBRichEdit.GetDataSource: TDataSource;

begin

Result := FDataLink.DataSource;

end;

procedure TDBRichEdit.SetDataSource(Value: TDataSource);

begin

FDataLink.DataSource := Value;

if Value <> nil then Value.FreeNotification(Self);

end;

function TDBRichEdit.GetDataField: string;

begin

Result := FDataLink.FieldName;

end;

procedure TDBRichEdit.SetDataField(const Value: string);

begin

FDataLink.FieldName := Value;

end;

function TDBRichEdit.GetReadOnly: Boolean;

begin

Result := FDataLink.ReadOnly;

end;