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. |
Partager