Composant basé sur TWebBrowser pour afficher les formats images non supportées par D7

Htmimage.pas
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
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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
unit Htmimage;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,mshtml, OleCtrls, SHDocVw, ExtCtrls, Buttons, StdCtrls;
type
  TWebImage=class(TPanel)
  private
    FWBrowser: TWebBrowser;
    FAutosize: boolean;
    FStretch : boolean;
    FFilename: string;
    FBRPrent : TWincontrol;
    IImg     : IHTMLImgElement;
    procedure LoadImg();
    procedure Set_Autosize(const Value: boolean);
    procedure Set_Filename(const Value: string);
    procedure Set_Stretch(const Value: boolean);
  protected
    function IntStl():string;virtual;
    procedure Navigate();
    procedure SetParent(AParent:TWinControl);override;
  public
    constructor Create(AOwner:TComponent);override;
    property Filename:string read FFilename write Set_Filename;
  published
    property Autosize:boolean read FAutosize write Set_Autosize;
    property Stretch :boolean read FStretch write Set_Stretch;
  end;
 
  TColorRec = packed record case LongInt of
    0: (Color       : LongInt);
    1: (ColorRef    : Dword);  {by Dr.Who}
    2: (Bytes       : array [0..3] of byte);
    3: (R, G, B, A  : Byte);
    4: (SysColorIdx : word; _unused : byte; IsSysColor: boolean);
  end;
 
procedure Register ;
 
implementation
 
procedure register;
begin
   registerComponents('Exemples',[TWebImage]);
end;
{ TWebImage }
 
constructor TWebImage.Create(AOwner: TComponent);
begin
  inherited;
  BevelOuter:=bvNone;
  FBRPrent := TWincontrol.Create(Self);
  FBRPrent.Parent := Self;
  FBRPrent.Align  := alClient;
  FBRPrent.Enabled:= false;
  Height:=120;
  Width :=100;
  if not (csDesigning in ComponentState) then
  begin
    FWBrowser:=TWebBrowser.Create(Self);
    FWBrowser.Align:=alClient;
    TControl(FWBrowser).Parent :=FBRPrent;
  end;
end;
 
function TWebImage.IntStl: string;
var
 C:TColorRec;
begin
  C.Color := Color;
  if C.IsSysColor then
     C.Color := GetSysColor(C.SysColorIdx);
  result:='about:'#13#10
         +'<html>'#13#10
         +'<head>'#13#10
         +'<style type="text/css">'#13#10
         +'<!--'#13#10
         +'body{margin : 0;'#13#10
         +'    background-color:'+Format('#%.2x%.2x%.2x',[C.R,C.G,C.B])+';'#13#10
         +'    overflow:hidden;'#13#10
         +'    border:0;'#13#10
         +'    position:absolute;'#13#10
         +'    left:0px;'#13#10
         +'    top:0px;'#13#10
         +'    width:'+InttoStr(Width)+'px;'#13#10
         +'    height:'+InttoStr(Height)+'px;'#13#10
         +'    z-index:1;'#13#10
         +'}'#13#10
         +'-->'#13#10
         +'</style>'#13#10
         +'</head>'#13#10
         +'<body>'#13#10
         +'<img src="'+FFilename+'"/>'#13#10
         +'</body>'#13#10
         +'</html>';
end;
 
procedure TWebImage.Navigate();
var
  All: IHTMLElementCollection;
begin
 
    FWBrowser.Navigate(IntStl());
    while FWBrowser.ReadyState <> READYSTATE_COMPLETE do
    begin
      Application.ProcessMessages();
      Sleep(3);
    end;
    All:=IHTMLDocument2(FWBrowser.Document).images;
    if All.length = 1 then
     IImg := All.item(0, EmptyParam) as  IHTMLImgElement ;
end;
 
procedure TWebImage.LoadImg;
begin
 if csDesigning in ComponentState then Exit;
 if not Fileexists(FFilename) then Exit;
 if Parent = nil then  Exit;
 
 if IImg = nil then Navigate();
 
 try
   if Autosize then
    begin
       Navigate();
       Height:=IImg.height;
       Width :=IImg.width;
    end
        else
        IImg.src:= FFilename;
 
   if Stretch then
    begin
       IImg.height:= Height;
       IImg.width := Width;
    end;
 except
    IImg.src:='';
 end;
end;
 
procedure TWebImage.Set_Autosize(const Value: boolean);
begin
  if FAutosize <> Value then
  begin
   FAutosize := Value;
   if FAutosize then
      FStretch := False;
   LoadImg();
  end;
end;
 
procedure TWebImage.Set_Stretch(const Value: boolean);
begin
  if FStretch <> Value then
  begin
   FStretch := Value;
   if FStretch then
      FAutosize := False
    else
     IImg:=nil;
   LoadImg();
  end;
end;
 
procedure TWebImage.Set_Filename(const Value: string);
begin
  if Value =FFilename then  Exit;
  FFilename := Value;
  LoadImg();
end;
 
procedure TWebImage.SetParent(AParent:TWinControl);
begin
  inherited;
  LoadImg();
end;
 
end.
exemple
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
procedure TForm1.Button1Click(Sender: TObject);
var
  WebImage: TWebImage;
begin
    WebImage:=TWebImage.Create(Self);
    with WebImage do
    try
       Parent:=Self;
       Filename:='C:\min.jpg';
       //Autosize:=true;
       Stretch :=true;
    except
      Free();
    end;
end;