...show better links in a TJvxRichEdit ?

Author: Sven Mörs
Homepage: http://www.delphi-area.de.tc

Category: VCL

{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), nilnil, SW_SHOWNORMAL);
end;

end.

 

printed from
www.swissdelphicenter.ch
developers knowledge base