afficher les images non supportees par D7

**Montor** · 22/12/2009, 14h12

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;

**Franck SORIANO** · 22/12/2009, 21h53

Utiliser un TWebBrowser juste pour afficher une image

?

comment dire... c'est pas un peu lourd pour pas grand chose ?
Pourquoi ne pas utiliser un truc gratuit du genre :
GraphicEx pour ajouter le support des formats non gérés ?

**Montor** · 26/12/2009, 12h09

c'est vrai au chargement pour la première fois mais excellent pour faire défiler plusieurs images dans un dossier ou DB effets fondu, gif animé...

afficher les images non supportees par D7

Contribuez Delphi

Discussions similaires

Partager

Partager