{{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
unit ads_WebRequest;
(*
Procedure WebGetResponse(var Response : TWebResponse);
Var
sgSrc : String;
sgExt : String;
lst : TStringList;
Content_Type : String;
begin
ProcName := 'WebImageRequest'; Try
lst := TStringList.Create();
Try
Content_Type := 'image/jpeg';
Response.ContentType := '';
Response.Content := '';
lst.SetText(PChar(WebRequest.Text));
If UpperCase(lst.Values['Request.Method'])='GET' Then
Begin
sgSrc := lst.Values['Request.QueryFields.Item.src'];
End
Else
Begin
sgSrc := lst.Values['Request.ContentFields.Item.src'];
End;
If sgSrc = '' Then
Begin
If lst.Values['Request.PathInfo'] <> '' Then
Begin
sgSrc := lst.Values['Request.PathInfo'];
sgSrc := StringReplace(sgSrc,'/','\',[rfReplaceAll]);
sgSrc := ExtractFileName(sgSrc);
End
Else
Begin
Exit;
End;
End;
sgSrc := StringReplace(sgSrc,'"','',[rfReplaceall]);
sgSrc := ExtractFileName(sgSrc);
If Not FileExists(GlobalCachePath+sgSrc) Then Exit;
(*
//In case the content is still being produced allow 30 seconds
If Not FileExists(sgSrc) Then
Begin
For inWait := 1 To 30 Do
Begin
Sleep(1000);
If FileExists(sgSrc) Then Break;
If inWait >= 30 Then Exit;
End;
End;
*)
Content_Type := '';
sgExt := ExtractFileExt(sgSrc);
sgExt := UpperCase(sgExt);
If sgExt = '.JPG' Then Content_Type := 'image/jpeg';
If sgExt = '.JPEG' Then Content_Type := 'image/jpeg';
If sgExt = '.JPE' Then Content_Type := 'image/jpeg';
If sgExt = '.GIF' Then Content_Type := 'image/gif';
If sgExt = '.HTM' Then Content_Type := 'text/html';
If sgExt = '.HTML' Then Content_Type := 'text/html';
If sgExt = '.XBM' Then Content_Type := 'image/x-xbitmap';
If sgExt = '.XPM' Then Content_Type := 'image/x-xpixmap';
If sgExt = '.PDF' Then Content_Type := 'application/pdf';
If sgExt = '.PNG' Then Content_Type := 'image/x-png';
If sgExt = '.IEF' Then Content_Type := 'image/ief';
If sgExt = '.TIF' Then Content_Type := 'image/tiff';
If sgExt = '.TIFF' Then Content_Type := 'image/tiff';
If sgExt = '.RGB' Then Content_Type := 'image/rgb';
Response.ContentType := Content_Type;
Response.Content := FileToStr(GlobalCachePath+sgSrc);
If FileExists(GlobalCachePath+sgSrc) Then DeleteFile(GlobalCachePath+sgSrc);
Finally
lst.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//
Procedure WebPostResponse_Default(var Response:TWebResponse;OutFile,DeviceType:String);
Var
inCounter : Integer;
begin
ProcName := 'WebPostResponse_Default'; Try
For inCounter := 1 To 300 Do
Begin
Application.ProcessMessages;
Sleep(1000);
If FileExists(OutFile) Then
Begin
If GetFileSize(OutFile) > 0 Then
Begin
Try
Response.Content := FileToStr(OutFile);
Response.ContentType := DeviceTypeToContentType(DeviceType);
WebResponseDeleteFile(OutFile);
Exit;
Except
Response.Content := 'Error';
Response.ContentType := 'text/html';
Break;
End;
End;
End;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//
Procedure WebPostResponse_HTML(var Response:TWebResponse;OutFile,DeviceType:String);
Var
inCounter : Integer;
begin
ProcName := 'WebPostResponse_HTML'; Try
For inCounter := 1 To 300 Do
Begin
Application.ProcessMessages;
Sleep(1000);
If FileExists(OutFile+'l') Then
Begin
If GetFileSize(OutFile+'l') > 0 Then
Begin
Try
Response.Content := FileToStr(OutFile+'l');
Response.ContentType := DeviceTypeToContentType(DeviceType);
WebResponseDeleteFile(OutFile);
Exit;
Except
Response.Content := 'Error';
Response.ContentType := 'text/html';
Break;
End;
End;
End;
If FileExists(OutFile) Then
Begin
If GetFileSize(OutFile) > 0 Then
Begin
Try
Response.Content := FileToStr(OutFile);
Response.ContentType := DeviceTypeToContentType(DeviceType);
WebResponseDeleteFile(OutFile);
Exit;
Except
Response.Content := 'Error';
Response.ContentType := 'text/html';
Break;
End;
End;
End;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//
Procedure WebPostResponse_SingleFile(var Response:TWebResponse;OutFile,Caption:String);
Var
inCounter : Integer;
begin
ProcName := 'WebPostResponse_SingleFile'; Try
For inCounter := 1 To 1000 Do
Begin
Application.ProcessMessages;
Sleep(300);
If FileExists(OutFile) Then
Begin
If GetFileSize(OutFile) > 0 Then
Begin
Try
Response.Content :=
''+#13+
''+#13+
'' +#13+
''+#13+
'' +#13+
'
'+#13+
''+#13+
'';
Response.ContentType := 'text/html';
Exit;
Except
Response.Content := 'Error';
Response.ContentType := 'text/html';
Break;
End;
End;
End;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//Unit DescriptionUnitIndexMaster Index
Procedure WebResponseDeleteFile(OutFile:String);
Var
sgExt : String;
begin
ProcName := 'WebResponseDeleteFile'; Try
sgExt := UpperCase(ExtractFileExt(OutFile));
If FileExists(OutFile) Then
DeleteFile(OutFile)
;
If sgExt = '.HTM' Then If FileExists(OutFile+'l') Then WebResponseDeleteFile(OutFile+'l');
If sgExt = '.HTML' Then If FileExists(Copy(OutFile,1,Length(OutFile)-1)) Then WebResponseDeleteFile(Copy(OutFile,1,Length(OutFile)-1));
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
//
Function BitmapToGif(BitmapFile,GifFile:String;DeleteBitmap: Boolean): Boolean;
Var
Gif : TGifImage;
Bitmap : TBitmap;
sgBExt : String;
sgGExt : String;
sgGDir : String;
begin
Result := False;
ProcName := 'BitmapToGif'; Try
If Not FileExists(BitmapFile) Then Exit;
BitmapFile:= Trim(BitmapFile);
GifFile := Trim(GifFile);
If BitmapFile = '' Then Exit;
If GifFile = '' Then Exit;
sgBExt := UpperCase(ExtractFileExt(BitmapFile));
sgGExt := UpperCase(ExtractFileExt(GifFile));
If sgBExt <> '.BMP' Then Exit;
If sgGExt <> '.GIF' Then Exit;
sgGDir := ExtractFilePath(GifFile);
If Not DirectoryExists(sgGDir) Then ForceDirectories(sgGDir);
If FileExists(GifFile) Then DeleteFile(GifFile);
Gif := TGifImage.Create();
Bitmap := TBitmap.Create();
Try
Bitmap.LoadFromFile(BitmapFile);
Gif.Assign(Bitmap);
Gif.SaveToFile(GifFile);
Finally
Bitmap.Free;
Gif.Free;
End;
If DeleteBitmap Then DeleteFile(BitmapFile);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
end;
Initialization
WebRequest := TStringList.Create();
WebRequestIsSet := False;
GlobalExePath := ExtractFileDir(ParamStr(0));
If Copy(GlobalExePath,Length(GlobalExePath),1) <> '\' Then
GlobalExePath := GlobalExePath + '\';
If DirectoryExists('Z:\') Then
Begin
GlobalCachePath := 'Z'+Copy(GlobalExePath,2,Length(GlobalExePath)-1);
If Not DirectoryExists(GlobalCachePath) Then ForceDirectories(GlobalCachePath);
End
Else
Begin
GlobalCachePath := GlobalExePath;
End;
GlobalReportsPath := GlobalExePath + 'Exes\';
GlobalExeName := ExtractFileName(ParamStr(0));
GlobalExeName := Copy(GlobalExeName,1,Length(GlobalExeName)-4);
GlobalExeName := LowerCase(GlobalExeName);
Finalization
WebRequest.Free;
end.
//