Discussion :

[Montor]

Tester sous Delphi7
Voici ce morceau de code qui permet dessiner le texte d'un richedit sur une image (.bmp)le code n'est pas très élégant mais reste utilisable

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Uses richedit;
procedure PrintRichedit(ARichEdit:TRichEdit;ACanvas:TCanvas;SLine:Integer=0;ELine:Integer=-1);
var
  CharRange: TFormatRange;
  sBitmap:TBitmap;
  SPos,EPos:Integer;
begin
    sBitmap:=TBitmap.Create;
    FillChar(CharRange, SizeOf(TFormatRange), 0);
 try
  with ARichEdit do
    begin
      sBitmap.Height:=ClientHeight;
      sBitmap.Width:=ClientWidth;
      sBitmap.Canvas.Brush.Color:=Color;
      sBitmap.Canvas.FillRect(ClientRect);
      if(ELine<>-1) then inc(ELine);
      SPos:=Perform(EM_LINEINDEX,SLine,0);
      EPos:=Perform(EM_LINEINDEX,ELine,0);
  with sBitmap.Canvas, CharRange do
    begin
      chrg.cpMin:=0;
      chrg.cpMax := -1;
      if(((SPos<>-1)and (EPos<>-1))and (SPos <= EPos)) then
      begin
        chrg.cpMin:=SPos;
        chrg.cpMax:=EPos;
      end;
      hdc := Handle;
      rc:=ClientRect;
      hdcTarget := Handle;
      rc.left:=0;
      rc.top :=0;
      rc.right :=MulDiv(rc.right,1440,GetDeviceCaps(Handle, LOGPIXELSX));
      rc.bottom :=MulDiv(rc.bottom,1440,GetDeviceCaps(Handle, LOGPIXELSY));
      rcPage := rc;
    end;
      Perform(EM_FORMATRANGE, 0, 0);
      Perform(EM_FORMATRANGE, 1, Longint(@CharRange));
      Perform(EM_FORMATRANGE, 0, 0);
      TransparentBlt(ACanvas.Handle,2,2,ClientWidth,ClientHeight,
      sBitmap.Canvas.Handle,0,0,ClientWidth,ClientHeight,ColorToRgb(Color));
  end;
 finally
    sBitmap.Free;
 end;
end;

Utilisation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
procedure TForm1.Button1Click(Sender: TObject);
begin
  PrintRichedit(RichEdit1,Image1.Canvas,0,10);
  Image1.Invalidate;
end;

le toisième et quatrième paramètre sont les début et fin des lignes sélectionnées mais attention à la property WordWrap .

[Montor]

Voici une pseudo infobulle Office 2007
J'ai redéfini La fonction GradientFill sous Delphi7 qui ne marche pas est défini comme ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
function GradientFill(DC: HDC; var Vertex: TTriVertex; NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall;

Sous Delphi 2006

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall;

Mais pas seulement la fonction GradientFill qu’il faut la redéfinir mais aussi COLOR16 déclarer Shortint sous Delphi7 est Word sous Delphi 2006 est qui va impliquer touts les type définies qu'il le utilise dans mon cas c'est TTriVertex

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
unit PersoHint;
interface
uses
  Windows, Messages, SysUtils,Classes, Graphics, Controls, Forms;
type
  TPersoHintWindow = class(THintWindow)
  private
    procedure drw;
  protected
    procedure CreateParams(var Params: TCreateParams);override;
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;
var
  HintStartColor:TColor;
  HintEndColor:TColor;
implementation
type
    COLOR16 = Word;
    TTriVertex = packed record
      x: Longint;
      y: Longint;
      Red: COLOR16;
      Green: COLOR16;
      Blue: COLOR16;
      Alpha: COLOR16;
    end;
function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall;external 'msimg32.dll';
 
constructor TPersoHintWindow.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   HintStartColor:=clWhite;
   HintEndColor:=$00FFDACA;
end;
 
procedure TPersoHintWindow.drw;
 procedure Cplt(Var AVertex:TTriVertex;AColor:TColor);
  begin
     AVertex.Red:=GetRValue(AColor) shl 8;
     AVertex.Green:=GetGValue(AColor)shl 8;
     AVertex.Blue:=GetBValue(AColor)shl 8;
     AVertex.Alpha:=0;
  end;
var
vertex:array[0..1] of TTriVertex;
gTri    :TGradientRect;
begin
  with ClientRect do
   begin
    Cplt(vertex[0],HintStartColor);
    vertex[0].X:=Left;
    vertex[0].Y:=Top;
    Cplt(vertex[1],HintEndColor);
    vertex[1].X:=Right-Left;
    vertex[1].Y:=Bottom-Top;
 end;
  gTri.UpperLeft := 0;
  gTri.LowerRight := 1;
  GradientFill(Canvas.handle,@vertex , 2, @gTri, 1, GRADIENT_FILL_RECT_V);
end;
 
procedure TPersoHintWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    Style := WS_POPUP  and not WS_BORDER ;
end;
 
procedure TPersoHintWindow.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
 Msg.Result :=1;
end;
 
procedure TPersoHintWindow.Paint;
begin
  drw;
  inherited;
end;
 
 initialization
 HintWindowClass := TPersoHintWindow;
end.

[Pedro]

Merci pour ta participation