...Links im TJvxRichEdit besser anzeigen?

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

printed from
www.swissdelphicenter.ch
developers knowledge base