unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, SHDocVw,urlmon,mshtml,wininet;
type
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
type
IHTMLElementRender = interface(IUnknown)
['{3050F669-98B5-11CF-BB82-00AA00BDCE0B}']
function DrawToDC
( _hDC: HDC
): HResult; stdcall;
end;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function GetCacheFileName(const Url: string; var FileName: string): Boolean;
var
Info: PInternetCacheEntryInfo;
InfoBufSize: Cardinal;
begin
Result := False;
InfoBufSize := 0;
GetUrlCacheEntryInfo(PChar(Url),
TInternetCacheEntryInfo(nil^), InfoBufSize);
if GetLastError = ERROR_INSUFFICIENT_BUFFER then begin
GetMem(Info, InfoBufSize);
try
Result := GetUrlCacheEntryInfo(PChar(Url),
TInternetCacheEntryInfo(Info^), InfoBufSize);
if Result then begin
FileName := Info^.lpszLocalFileName;
end;
finally
FreeMem(Info);
end;
end;
end;
procedure SaveImageFromIHtmlDocument2(AIHtmlDocument2: IHtmlDocument2; const ADir: string);
var Images: IHTMLElementCollection;
i, P: Integer;
ImgElement: IHTMLImgElement;
Buff: Pointer;
BuffSize: DWORD;
URL: String;
NewName: string;
ElementRender: IHTMLElementRender;
Bitmap: TBitmap;
begin
if not Assigned(AIHtmlDocument2) then exit;
Images := AIHtmlDocument2.images;
if not Assigned(Images) then exit;
for i := 0 to Images.length - 1 do
if Succeeded(Images.item(i, 0).QueryInterface(IHTMLImgElement, ImgElement)) then
try
URL := ImgElement.src;
NewName := URL;
P := LastDelimiter('/', NewName);
if P > 0 then Delete(NewName, 1, P);
NewName := ChangeFileExt(ADir + NewName, '.bmp');
Buff := nil;
BuffSize := 0;
if not RetrieveUrlCacheEntryFile(PChar(URL), TInternetCacheEntryInfo(Buff^), BuffSize, 0) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
GetMem(Buff, BuffSize);
try
if RetrieveUrlCacheEntryFile(PChar(URL), TInternetCacheEntryInfo(Buff^), BuffSize, 0) then
try
if Succeeded(ImgElement.QueryInterface(IHTMLElementRender, ElementRender)) then
try
Bitmap := TBitmap.Create;
try
with ImgElement as IHTMLElement, Bitmap, Canvas do
begin
Width := offsetWidth;
Height := offsetHeight;
Brush.Color := clWhite;
FillRect(ClipRect);
ElementRender.DrawToDC(Handle);
SaveToFile(NewName);
end;
finally
Bitmap.Free;
end;
finally
ElementRender := nil;
end;
finally;
end;
finally
ImgElement := nil;
end;
end;
finally
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveImageFromIHtmlDocument2(WebBrowser1.Document as IHTMLDocument2, 'd:\');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
webbrowser1.Silent:=true;
webbrowser1.Navigate('m.vk.com/');
end;
end.
18.10.2012, 16:11
Ошибка сохранении картинки из twebbrowser
Комбинированный вид
