{You'll need a TJvxRichEdit and a TButton.}
{Wir benötigen TJvxRichEdit und einen TButton.}
{
The original component doesn't allow everything with URLs. This version add
the possibility of choosing color, put a FTP or MailTo-Link....
Wer die Komponente kennt, weist das es im TJvxRichEdit schon eine Funktion
gibt zum anzeigen URL'S.
Hier hatt der User aber freie wahl und kann die Link Farbe selbst bestimmen.
Und es ist Kinderleicht weitere URL's hinzufügen. Z.b. Mail-Addressen,
FTP-Linksm, ...alles was man will.}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, RichEdit, JvRichEd, Shellapi;
type
TForm1 = class(TForm)
JvxRichEdit1: TJvxRichEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure JvxRichEdit1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormCreate(Sender: TObject);
procedure JvxRichEdit1DblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
RTF: string;
mword: string;
implementation
{$R *.dfm}
{Wort auf Links prüfen -> Cursor ändern}
procedure PruefeWord(RichEdit: TjvxRichEdit; Word1: string);
begin
if Length(word1) > 1 then
if word1[1] = ' ' then
Delete(word1, 1, 1);
//Http:// - LInks
if Pos(UpperCase('http://'), UpperCase(Word1)) = 1 then //http:// an der 1 stelle?
begin
if (Pos('.', Word1) > 8) then //Ist der . an der stelle 9 oder größer
RichEdit.Cursor := crHandPoint;
end
else
begin
//www. - Links
if Pos(UpperCase('www.'), UpperCase(Word1)) = 1 then //www. an der 1 stelle?
begin
if LastDelimiter('.', Word1) > Pos('.', Word1) then //Letzter . größer als der 1?
RichEdit.Cursor := crHandPoint;
end
else
RichEdit.Cursor := crDefault;
end;
end;
{Wort unterm Cursor ermitteln}
procedure GetWord(Sender: TObject; X, Y: Integer);
var
CIndex, LIndex, Offset, i, j: Integer;
Pt: TPoint;
s: string;
begin
with TjvxRichEdit(Sender) do
begin
Pt := Point(X, Y);
CIndex := Perform(Messages.EM_CHARFROMPOS, 0, Integer(@Pt));
if CIndex < 0 then
begin
MWord := '';
Cursor := crDefault;
Exit;
end;
LIndex := Perform(EM_EXLINEFROMCHAR, 0, CIndex);
Offset := CIndex - Perform(EM_LINEINDEX, LIndex, 0);
if Lines.Count - 1 < LIndex then
begin
MWord := '';
Cursor := crDefault;
Exit;
end;
s := Lines[LIndex];
i := Offset + 1;
while (i > 0) and (s[i] <> ' ') do Dec(i);
j := Offset + 1;
while (j <= Length(s)) and (s[j] <> ' ') do Inc(j);
MWord := Copy(s, i, j - i);
end;
PruefeWord(TjvxRichEdit(Sender), MWord);
end;
{Text ins TRichEdit laden.}
procedure LoadContent(Redit: TJvxRichedit; RTFCode: string);
var
sl: TStringList;
ms: TMemoryStream;
begin
sl := TStringList.Create;
try
ms := TMemoryStream.Create;
try
sl.Text := RTFCode;
sl.SaveToStream(ms);
ms.Seek(0,0);
if redit <> nil then
redit.Lines.AddObject(rtfcode, ms);
finally
ms.Free;
end;
finally
sl.Free;
end;
end;
{Text hinzufügen - Links makieren}
function AddContent(RichEdit: TjvxRichEdit; Content: string): string;
var
Word: string;
begin
Result := Content;
if not (Content[Length(Content)] = ' ') then //keine Leerstelle zum schluss
Content := Content + ' '; //Leerstelle hinzufügen - Für letztes Wort.
while Pos(' ', Content) <> 0 do //Leerstelle vorhanden?
begin
Word := Copy(Content, 0, Pos(' ', Content) - 1); //Wort kopieren
//Http:// - Links
if Pos(UpperCase('http://'), UpperCase(Word)) = 1 then //http:// an der 1 stelle?
begin
if (Pos('.', Word) > 8) then //Ist der . an der stelle 9 oder größer
Result := StringReplace(Result, Word, '\cf1\ul ' + Word +'\cf0\ulnone', [rfIgnoreCase]);
//Link makieren
{\cf1 = 1 Farbe. \cf0 = Normale Farbe "schwarz". \ul
unterstreicht ein Wort/Satz bis wieder \ulnone aufgerufen worden wurde}
end;
//www. - Links
if Pos(UpperCase('www.'), UpperCase(Word)) = 1 then //www. an der 1 stelle?
if LastDelimiter('.', Word) > Pos('.', Word) then //Letzter . größer als der 1?
Result := StringReplace(Result, Word, '\cf1\ul ' + Word +'\cf0\ulnone', [rfIgnoreCase]);
//Link makieren
Delete(Content, 1, Length(Word) + 1); //Wort aus String löschen.
end;
LoadContent(RichEdit, Result); //RTF-Code laden.
end;
{RTF-Code erstellen}
procedure SetRTF;
var
C: Longint;
r, g, b: Byte;
begin {Schrift art die später mit \f0 aufgerufen werden kann.
//Beispiel hinter dem vorletzten -> }
{\f1\fnil\fcharset0 Times New Roman;}
//<- Das dann mit \f1 aufrufen sehe 1 Parameter
RTF := '{\rtf1\ansi\ansicpg1252\deff0\deflang1031{\fonttbl{\f0\fswiss\fprq2\fcharset0 Arial;}}' +
#13#10 +
'{\colortbl ;';
C := ColorToRGB(clblue); //Farbe umwandeln
r := C; //Rot wert auslesen
g := C shr 8; //Grün wert
b := C shr 16; //Blau Wert
RTF := RTF + '\red' + IntToStr(r) + '\green' + IntToStr(g) + '\blue' + IntToStr(b) + ';';
//Farbe hinzufügen
RTF := RTF + '}' + '\viewkind4\uc1\pard\f0\fs24';
//Font laden Schriftart und Schriftgröße.
{f0 steht für die Schriftart, die oben angegeben wurde. fs24 (font size) die Schriftgröße}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AddContent(jvxRichEdit1, RTF + ' Delphi Seite: www.swissdelphicenter.ch \par }');
end;
procedure TForm1.JvxRichEdit1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
Getword(Sender, x, y);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
setrtf;
end;
procedure TForm1.JvxRichEdit1DblClick(Sender: TObject);
begin
if not (mword = '') then
if mword[1] = ' ' then
Delete(mword, 1, 1);
ShellExecute(Handle, 'open', PChar(Mword), nil, nil, SW_SHOWNORMAL);
end;
end.
|
