Quel composant memo pour lien Url

Version imprimable

03/03/2009, 10h06
Cazaux-Moutou-Philippe

Quel composant memo pour lien Url

Bonjour

quel composant de type mémo avec acces à la bdd utiliser pour mettre du texte mis en forme avec couleur, gras etc.., et possibilité de lien url cliquable

e quel type de colonne dans la bbd Firebird ??

merci
03/03/2009, 11h15
Gilbert Geyer

Salut,

Citation:

composant de type mémo avec acces à la bdd utiliser pour mettre du texte mis en forme avec couleur, gras etc..,

... impossible. Le TMemo c'est limité à du texte monochrome.
... pour du texte mis en forme et polychrome il faut du TRichEdit.

A+ :D
03/03/2009, 14h19
Cazaux-Moutou-Philippe

Citation:

TRichEdit

Oui je l ai aussi mis, mais je ne peux pas y mettre d url cliquable

n'y a t il pas de compos pour D7, qui inclurai aussi une toolbar avec les possibilités (gras etc..)

j avais vu un compo comme ca mais impossible de le retrouver
03/03/2009, 16h08
Gilbert Geyer
Re-Salut,

En utilisant un TRichEdit il est possible :

1) D'utiliser son onMouseMove pour détecter si la SubStringMotSousCurseurDeLaSouris commence par 'http:' et dans ce cas tu récupères ce nom sinon tu fais SubStringMotSousCurseurDeLaSouris:='';
(tu peux en profiter pour changer sa couleur au passage de la souris mais ça c'est des fioritures).

2) Ensuite tu peux utiliser le onMouseDown du RichEdit pour utiliser le lien :
Code:

1 2 3 4 begin ShellExecute(Handle,'OPEN', PChar(SubStringMotSousCurseurDeLaSouris), Nil,Nil,SW_SHOW); end;
... pour ShellExecute ajouter ShellApi dans le uses.

A+ :D

Lien url dans un TRichEdit

Re-Salut,

Je viens de retrouver l'appli dans laquelle j'avais fait ça avec un RichEdit mais un peu différemment (tout se passe dans le MouseDown) voiçi le code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
 
Const coulLienDef = clNavy; coulLienVu = clTeal;
 
function IndexCarSouris(UnEdit: TCustomEdit; ClientPos: TPoint): Integer;
// Renvoie l''Index absolu du caractère le plus proche d'un point en coordonnées écran d'un TRichEdit, TEdit, ou TMemo
var      lParam: Integer;
begin    if UnEdit is TRichEdit then
         begin lParam:= Integer(@ClientPos);
               result:= UnEdit.Perform(EM_CHARFROMPOS, 0, lParam);
         end else
         begin lParam:= ClientPos.Y shl 16 + ClientPos.X;
               result:= LoWord(UnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); //index caractère
               //result:= HiWord(UnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); //index ligne
         end;
end;
 
function MotSousMouse(UnEdit: TCustomEdit; ClientPos: TPoint; var icd,ics,icf : integer): string;
var      lg : integer; //icd,ics,icf : indexes car deb,souris,fin
begin    ics:=IndexCarSouris(UnEdit,ClientPos);
         icd:=ics+1; icf:=ics-1; lg:=length(UnEdit.Text);
         repeat dec(icd);
         until (icd=1) or (UnEdit.Text[icd] in [' ',#09,#10,#13]);
         repeat inc(icf);
         until (icf=lg) or (UnEdit.Text[icf] in [' ',#09,#10,#13]);
         if UnEdit.Text[icd] in [' ',#09,#10,#13] then inc(icd);
         if UnEdit.Text[icf] in [' ',#09,#10,#13] then dec(icf);
         Result:=copy(UnEdit.text,icd,icf-icd+1)
end;
 
procedure TfrmGen.redGenMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var       lienUrl : string; ics,icd,icf : integer; clPrec : tColor;
begin     if (ssCtrl in Shift) and (Button=mbLeft) then // Simulation lien hypertexte
          begin  lienUrl:=MotSousMouse(redGen, Point(X, Y),icd,ics,icf);
                if pos('http',lienUrl)>0 then
                begin with redGen do // Marquage
                      begin SelStart:=icd-1; SelLength:=icf-icd+1;
                            clPrec:=SelAttributes.Color;
                            SelAttributes.Color:=coulLienVu;
                            SelLength:=0; SelStart:=ics;
                            SelAttributes.Color:=clPrec;
                            upDate;
                      end;
                      ShellExecute(Handle,'OPEN',PChar(lienUrl),Nil,Nil,SW_SHOW);
                end;
          end;
end; // TfrmGen.redGenMouseDown

... suffit de remplacer dans ce code redGen par le nom de ton RichEdit : par ex : RichEdit1.
... la combinaison Appui touche Ctrl + Appui-Bouton-Souris-Gauche lance le lien.

A+ :D

Composant TRichEditUrl

Bonjour,

Tant qu'à faire j'ai transformé le code de mon post précédent en composant dérivé du TRichEdit :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
unit cRichEditUrl;
 
// *****************************************************************************
// Composant TRichEditUrl dérivé du TRichEdit de façon à identifier un lien
// hypertexte activable par combinaison touche Ctrl + Appui-bouton-Souris-Gauche
// *****************************************************************************
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  StdCtrls, ComCtrls, ShellApi;
 
type TRichEditUrl = class(TRichEdit)
  private
    FColorLienActivable : TColor; // couleur prise par le lien hypertexte au passage de la souris
    FColorLienVu        : TColor; // couleur du lien après activation 
    procedure SetColorLienActivable(Value : TColor);
    procedure SetColorLienVu(Value : TColor);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
  published
    property ColorLienActivable : TColor read FColorLienActivable write SetColorLienActivable;
    property ColorLienVu : TColor read FColorLienVu write SetColorLienVu;
end;
 
procedure Register;
 
implementation
 
procedure Register;
begin     RegisterComponents('Ajouts', [TRichEditUrl]);
end;
 
constructor TRichEditUrl.Create(AOwner: TComponent);
begin       inherited Create(AOwner);
            FColorLienActivable := clRed;
            FColorLienVu        := clTeal;
end;
 
destructor  TRichEditUrl.Destroy;
begin       inherited Destroy;
end;
 
function IndexCarSouris(UnEdit: TCustomEdit; ClientPos: TPoint): Integer;
// Renvoie Index absolu du caractère le plus proche d'un point en coordonnées
// écran d'un TRichEdit, TEdit, ou TMemo
var      lParam: Integer;
begin    if UnEdit is TRichEdit then
         begin lParam:= Integer(@ClientPos);
               result:= UnEdit.Perform(EM_CHARFROMPOS, 0, lParam);
         end else
         begin lParam:= ClientPos.Y shl 16 + ClientPos.X;
               result:= LoWord(UnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); //index caractère
               //result:= HiWord(UnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); //index ligne
         end;
end;
 
function MotSousMouse(UnEdit: TCustomEdit; ClientPos: TPoint; var icd,ics,icf : integer): string;
// Result = Mot sous curseur souris en position ClientPos
// var icd,ics,icf : Indexes des car deb,souris,et fin
var      lg : integer; 
begin    ics:=IndexCarSouris(UnEdit,ClientPos);
         icd:=ics+1; icf:=ics-1; lg:=length(UnEdit.Text);
         if lg=0 then begin Result:=''; EXIT; end; //< Ligne ajoutée le 5 mars 2009
         repeat dec(icd);
         until (icd=1) or (UnEdit.Text[icd] in [' ',#09,#10,#13]);
         repeat inc(icf);
         until (icf=lg) or (UnEdit.Text[icf] in [' ',#09,#10,#13]);
         if UnEdit.Text[icd] in [' ',#09,#10,#13] then inc(icd);
         if UnEdit.Text[icf] in [' ',#09,#10,#13] then dec(icf);
         Result:=copy(UnEdit.text,icd,icf-icd+1)
end;
 
procedure TRichEditUrl.SetColorLienActivable(Value : TColor);
begin     FColorLienActivable :=Value;
end;
 
procedure TRichEditUrl.SetColorLienVu(Value : TColor);
begin     FColorLienVu :=Value;
end;
 
procedure TRichEditUrl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var       lienUrl : string; ics,icd,icf : integer; clPrec : tColor;
begin     if (ssCtrl in Shift) and (Button=mbLeft) then // Activation du lien hypertexte
          begin lienUrl:=MotSousMouse(Self, Point(X, Y),icd,ics,icf);
                if pos('http',lienUrl)>0 then
                begin with Self do // Marquage comme Vu
                      begin SelStart:=icd-1; SelLength:=icf-icd+1;
                            clPrec:=SelAttributes.Color;
                            SelAttributes.Color:=ColorLienVu;
                            SelLength:=0; SelStart:=ics;
                            SelAttributes.Color:=clPrec;
                            upDate;
                      end;
                      ShellExecute(Handle,'OPEN',PChar(lienUrl),Nil,Nil,SW_SHOW);
                end;
          end;
end; // TRichEditUrl.MouseDown
 
procedure TRichEditUrl.MouseMove(Shift: TShiftState; X,Y: Integer);
var       lienUrl : string; ics,icd,icf : integer; clPrec : tColor;
begin     lienUrl:=MotSousMouse(Self, Point(X, Y),icd,ics,icf);
          if (pos('http',lienUrl)>0) then
          begin with Self do // Marquage comme activable
                begin SelStart:=icd-1; SelLength:=icf-icd+1;
                      clPrec:=SelAttributes.Color;
                      if (clPrec<>ColorLienActivable) and (clPrec<>ColorLienVu) then
                      begin SelAttributes.Color:=ColorLienActivable;
                            upDate;
                      end;
                      SelLength:=0; SelStart:=ics;
                end;
          end;
end; // TRichEditUrl.MouseMove
 
END. //=========================================================================

... reste plus qu'à créer le fichier .dcr avec l'Editeur d'images de Delphi et installer le composant.

A+ :D

EDIT du 5 mars 2009 : Ajoué une ligne de code dans la function MotSousMouse suite à la remarque de Lung

04/03/2009, 14h33
Cazaux-Moutou-Philippe

Merci je vais essayer ca des ce soir
05/03/2009, 08h12
Lung

Citation:

Envoyé par Gilbert Geyer

Tant qu'à faire j'ai transformé le code de mon post précédent en composant dérivé du TRichEdit

J'ai testé ton composant, mais j'ai une violation d'accès dans la fonction MotSousMouse à la ligne

Code:

until (icd=1) or (UnEdit.Text[icd] in [' ',#09,#10,#13]);

Si UnEdit.Text est vide, UnEdit.Text[icd] avec icd = 1 va planter.
05/03/2009, 10h18
Gilbert Geyer

Bonjour,

Merci Lung pour ton signalement.

J'ai ajouté dans la function MotSousMouse la ligne suivante :

Code:

if lg=0 then begin Result:=''; EXIT; end;

juste après celle-ci :

Code:

icd:=ics+1; icf:=ics-1; lg:=length(UnEdit.Text);

... d'où plus de plantage si UnEdit.Text est vide.

A+ :D

Composant TRichEditUrl version 2

Re-bonjour,

Voiçi une version modifiée de sorte que :
- tous les liens présents prennent la couleur de la property ColorLienActivable suite à un onChange,
- le curseur change de forme au survol d'un lien,
- et un lien qui a été activé par Ctrl + Appui-bouton-Souris-Gauche est repérable il passe en souligné.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
unit cRichEditUrl;
 
// *****************************************************************************
// Composant TRichEditUrl dérivé du TRichEdit de façon à identifier un lien
// hypertexte activable par combinaison touches Ctrl + Appui-bouton-Souris-Gauche
// *****************************************************************************
// Version 2 du 5 mars 2009 : modifié procedure MouseMove
//                          : ajouté procedure Change.
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ComCtrls, ShellApi;
 
type TRichEditUrl = class(TRichEdit)
  private
    FColorLienActivable : TColor;
    procedure SetColorLienActivable(Value : TColor);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
    procedure Change; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
  published
    property ColorLienActivable : TColor read FColorLienActivable write SetColorLienActivable;
end;
 
procedure Register;
 
implementation
 
procedure Register;
begin     RegisterComponents('Ajouts', [TRichEditUrl]);
end;
 
constructor TRichEditUrl.Create(AOwner: TComponent);
begin       inherited Create(AOwner);
            FColorLienActivable := clRed;
end;
 
destructor  TRichEditUrl.Destroy;
begin       inherited Destroy;
end;
 
function IndexCarSouris(UnEdit: TCustomEdit; ClientPos: TPoint): Integer;
//       Renvoie Index absolu du caractère le plus proche d'un point en
//       coordonnées écran d'un TRichEdit, TEdit, ou TMemo
var      lParam: Integer;
begin    if UnEdit is TRichEdit then
         begin lParam:= Integer(@ClientPos);
               result:= UnEdit.Perform(EM_CHARFROMPOS, 0, lParam);
         end else
         begin lParam:= ClientPos.Y shl 16 + ClientPos.X;
               result:= LoWord(UnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); //index caractère
               //result:= HiWord(UnEdit.Perform(EM_CHARFROMPOS, 0, lParam)); //index ligne
         end;
end;
 
function MotSousMouse(UnEdit: TCustomEdit; ClientPos: TPoint; var icd,ics,icf : integer): string;
//       Result = Mot sous curseur souris en position ClientPos
//       var icd,ics,icf : Indexes des car deb,souris,et fin
var      lg : integer; 
begin    ics:=IndexCarSouris(UnEdit,ClientPos);
         icd:=ics+1; icf:=ics-1; lg:=length(UnEdit.Text);
         if lg=0 then begin Result:=''; EXIT; end;
         repeat dec(icd);
         until (icd=1) or (UnEdit.Text[icd] in [' ',#09,#10,#13]);
         repeat inc(icf);
         until (icf=lg) or (UnEdit.Text[icf] in [' ',#09,#10,#13]);
         if UnEdit.Text[icd] in [' ',#09,#10,#13] then inc(icd);
         if UnEdit.Text[icf] in [' ',#09,#10,#13] then dec(icf);
         Result:=copy(UnEdit.text,icd,icf-icd+1)
end;
 
procedure TRichEditUrl.SetColorLienActivable(Value : TColor);
begin     FColorLienActivable :=Value;
end;
 
procedure TRichEditUrl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var       lienUrl : string; ics,icd,icf : integer; clPrec : tColor;
begin     if (ssCtrl in Shift) and (Button=mbLeft) then // Activation du lien hypertexte
          begin lienUrl:=MotSousMouse(Self, Point(X, Y),icd,ics,icf);
                if pos('http',lienUrl)>0 then
                begin with Self do // Marquage comme Vu
                      begin SelStart:=icd-1; SelLength:=icf-icd+1;
                            clPrec:=SelAttributes.Color;
                            SelAttributes.Style:=[fsUnderline];
                            SelLength:=0; SelStart:=ics;
                            SelAttributes.Color:=clPrec;
                            //upDate;
                      end;
                      ShellExecute(Handle,'OPEN',PChar(lienUrl),Nil,Nil,SW_SHOW);
                end;
          end;
end; // TRichEditUrl.MouseDown
 
procedure TRichEditUrl.MouseMove(Shift: TShiftState; X,Y: Integer);
//        Changer de curseur au survol d''un lien :
var       lienUrl : string; ics,icd,icf : integer; clPrec : tColor;
begin     lienUrl:=MotSousMouse(Self, Point(X, Y),icd,ics,icf);
          if (pos('http',lienUrl)>0) then Screen.Cursor := crHandPoint
                                     else Screen.Cursor := crDefault;
end;
 
procedure TRichEditUrl.Change; // Illuminer tous les liens
var       SelStartIni,i,lg,icd,icf : Integer; p : PChar;
begin     inherited Change;
          if csDesigning in ComponentState then EXIT;
          SelStartIni := Self.SelStart;
          lg:=length(Self.text);
          if lg < 8 then EXIT;
          i:=1; 
          p:=@Self.text[i];
          Repeat // voir si suite = http
                 if p^='h' then
                 begin icd:=i-1; inc(p); inc(i);
                       if p^='t' then
                       begin inc(p); inc(i);
                             if p^='t' then
                             begin inc(p); inc(i);
                                   if p^='p' then
                                   begin repeat inc(p); inc(i);
                                         until (i=lg) or (p^ in [' ',#09,#10,#13]);
                                         icf:=i-1;
                                         with Self do
                                         begin SelStart:=icd;
                                               SelLength:=icf-icd+1;
                                               SelAttributes.Color:=ColorLienActivable;
                                         end;
 
                                   end;
                             end;
                       end;
                 end;
                 inc(i); inc(p);
          until (i=lg);
          Self.SelStart := SelStartIni;
          Self.SelLength:= 0;
end;
 
END. //=========================================================================

A+ :D

Salut,

Le composant RichEdit est capable de reconnaitre les urls tout seul comme un grand.
Voici le code d'un dérivé supportant les urls http, https, mailto, ftp...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
 
  TKRichEdit = class(TRichEdit)
  private
    procedure DetectUrl;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  protected
    procedure LaunchURL(URL : string); virtual;
    procedure CreateWnd; override;
  end;
 
implementation
 
uses RichEdit, ShellApi;
 
{ TKRichEdit }
 
procedure TKRichEdit.CNNotify(var Message: TWMNotify);
var
  Link: TENLink;
begin
  inherited;
  if Message.NMHdr^.code = EN_LINK then
  begin
    Link := TENLink(Pointer(Message.NMHdr)^);
    if Link.Msg = WM_LBUTTONDOWN then
    begin
      SendMessage(Handle, EM_EXSETSEL, 0, Longint(@(Link.chrg)));
      LaunchURL(SelText);
    end;
  end;
end;
 
procedure TKRichEdit.CreateWnd;
begin
  inherited CreateWnd;
  DetectUrl;
end;
 
procedure TKRichEdit.DetectUrl;
var
  AMask: Word;
begin
  AMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(Handle, EM_SETEVENTMASK, 0, AMask or ENM_LINK);
  SendMessage(Handle, EM_AUTOURLDETECT, Integer(True), 0);
end;
 
procedure TKRichEdit.LaunchURL(URL: string);
begin
  ShellExecute(Handle, 'open', PChar(URL), nil, nil, SW_SHOW);
end;

"Simple is beautiful"

07/03/2009, 10h50
Gilbert Geyer

Bonjour,

Citation:

Le composant RichEdit est capable de reconnaitre les urls tout seul comme un grand.

... encore fallait-il le savoir.

En tous cas il est super ton code : la puissance de la simplicité. :king:

A+ :D
07/03/2009, 16h04
anapurna

salut

pour plus de detail voir ici

@+ Phil
07/03/2009, 16h50
Gilbert Geyer

Re-bonjour,

Merci Anapurna pour le lien : Vu.

A+ :D