Tack Tony, men tyvärr får jag det ej att fungera, man ser att programmet hämtar hem filen, men den klarar ej att presentera det, får felet "Project Project1.exe raised exception class EConvertError with message 'Cannot assign TForm1 to a TPicture' Process stopped. Use Step or Run to continue.", raden "GetURL(self);" markeras sen.
Nedan är komplett kod:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
HttpProt, ExtCtrls, StdCtrls, ShellAPI, GifImage;
type
TForm1 = class(TForm)
Image1: TImage;
InfoLabel: TLabel;
Timer1: TTimer;
HttpCli1: THttpCli;
Image2: TImage;
procedure HttpCli1DocData(Sender: TObject; Buffer: Pointer;
Len: Integer);
procedure HttpCli1HeaderData(Sender: TObject);
procedure Image1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure GetData(Sender: TObject);
procedure GetURL(Sender: TObject);
end;
var
Form1: TForm1;
URL : string;
implementation
{$R *.DFM}
procedure ExploreWeb(handle:HWND ; page:PChar);
var
Returnvalue : integer;
begin
ReturnValue := ShellExecute(handle, 'open', page, nil, nil, SW_SHOWNORMAL);
if ReturnValue <= 32 then
case Returnvalue of
0 : MessageBox(handle,'Error: Out of Memory','Error',0);
ERROR_FILE_NOT_FOUND: MessageBox(handle,'Error: File not found','Error',0);
ERROR_PATH_NOT_FOUND: MessageBox(handle,'Error: Directory not','Error',0);
ERROR_BAD_FORMAT : MessageBox(handle,'Error: Wrong format in EXE','Error',0);
// All other errors . See help for more ReturnValues of ShellExecute
else
MessageBox(handle,PChar('Error Nr: '+IntToStr(Returnvalue)+' in ShellExecute'),'Error',0)
end //case
end;
procedure TForm1.GetURL(Sender: TObject);
begin
HttpCli1.URL := 'http://www.mindomän.com/servlet/MittServlet';
HttpCli1.RcvdStream := TMemoryStream.Create;
InfoLabel.Caption := 'Loading';
try
try
HttpCli1.Get;
InfoLabel.Caption := 'Received ' +
IntToStr(HttpCli1.RcvdStream.Size) + ' bytes';
SetLength(URL, HttpCli1.RcvdStream.Size);
HttpCli1.RcvdStream.Position := 0;
HttpCli1.RcvdStream.Read(URL[1],HttpCli1.RcvdStream.Size);
except
on E: EHttpException do
begin
InfoLabel.Caption := 'Failed : ' +
IntToStr(HttpCli1.StatusCode) + ' ' +
HttpCli1.ReasonPhrase;;
end
else
raise;
end;
finally
HttpCli1.RcvdStream.Destroy;
HttpCli1.RcvdStream := nil;
end;
end;
procedure TForm1.GetData(Sender: TObject);
var
GIF : TGIFImage;
begin
HttpCli1.URL := 'http://www.mindomän.com/images/banner.gif';
HttpCli1.RcvdStream := TMemoryStream.Create;
InfoLabel.Caption := 'Loading';
try
try
HttpCli1.Get;
InfoLabel.Caption := 'Received ' +
IntToStr(HttpCli1.RcvdStream.Size) + ' bytes';
HttpCli1.RcvdStream.Position := 0;
try
//Image1.Picture.Bitmap.LoadFromStream(HttpCli1.RcvdStream);
GIF.LoadFromStream(HttpCli1.RcvdStream);
//
// visa bilden i image1
//
Image1.Picture.Assign(GIF);
except
InfoLabel.Caption := 'Failed : Can''t load banner'
end;
except
on E: EHttpException do
begin
InfoLabel.Caption := 'Failed : ' +
IntToStr(HttpCli1.StatusCode) + ' ' +
HttpCli1.ReasonPhrase;;
end
else
raise;
end;
finally
HttpCli1.RcvdStream.Destroy;
HttpCli1.RcvdStream := nil;
end;
end;
procedure TForm1.HttpCli1DocData(Sender: TObject; Buffer: Pointer;
Len: Integer);
begin
InfoLabel.Caption := IntToStr(HttpCli1.RcvdCount);
end;
procedure TForm1.HttpCli1HeaderData(Sender: TObject);
begin
InfoLabel.Caption := InfoLabel.Caption + '.';
end;
procedure TForm1.Image1Click(Sender: TObject);
begin
if URL <> '' then
ExploreWeb(handle,PChar(URL));
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Interval := 60000;
GetData(self);
GetURL(self);
InfoLabel.Caption := 'Done (click it!)';
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := true;
end;
end.
DU ser att gammal rad, som fungerar med en .bmp-bild är bortkommenterad.
tack
Andreas