CountWm.pas
上传用户:fh681027
上传日期:2022-07-23
资源大小:1959k
文件大小:2k
源码类别:

Delphi控件源码

开发平台:

Delphi

  1. unit CountWm;
  2. interface
  3. uses
  4.   Windows, SysUtils, HTTPApp;
  5. type
  6.   TWebModule1 = class(TWebModule)
  7.     procedure WebModule1WebActionItem1Action(Sender: TObject;
  8.       Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  9.   end;
  10. var
  11.   WebModule1: TWebModule1;
  12. implementation
  13. {$R *.DFM}
  14. uses
  15.   Graphics, Jpeg, ExtCtrls, Classes;
  16. procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  17.   Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  18. var
  19.   Bitmap: TBitmap; // Image: TImage;
  20.   nHit: Integer;
  21.   LogFile: Text;
  22.   LogFileName: string;
  23.   Jpeg1: TJpegImage;
  24.   Stream: TMemoryStream;
  25. begin
  26.   LogFileName := 'WebCont.log';
  27.   System.Assign (LogFile, LogFileName);
  28.   try
  29.     // read if the file exists
  30.     if FileExists (LogFileName) then
  31.     begin
  32.       Reset (LogFile);
  33.       Readln (LogFile, nHit);
  34.       Inc (nHit);
  35.     end
  36.     else
  37.       nHit := 0;
  38.     // saves the new data
  39.     Rewrite (LogFile);
  40.     Writeln (LogFile, nHit);
  41.   finally
  42.     Close (LogFile);
  43.   end;
  44.   // simple version (text only counter)
  45.   Response.Content := IntToStr (nHit);
  46.   // create a bitmap in memory
  47.   Bitmap := TBitmap.Create;
  48.   try
  49.     Bitmap.Width := 120;
  50.     Bitmap.Height := 25;
  51.     // draw the digits
  52.     Bitmap.Canvas.Font.Name := 'Arial';
  53.     Bitmap.Canvas.Font.Size := 14;
  54.     Bitmap.Canvas.Font.Color := RGB (255, 127, 0);
  55.     Bitmap.Canvas.Font.Style := [fsBold];
  56.     Bitmap.Canvas.TextOut (1, 1, 'Hits: ' +
  57.       FormatFloat ('###,###,###', Int (nHit)));
  58.     // convert to JPEG and output
  59.     Jpeg1 := TJpegImage.Create;
  60.     try
  61.       Jpeg1.CompressionQuality := 50;
  62.       Jpeg1.Assign(Bitmap);
  63.       Stream := TMemoryStream.Create;
  64.       Jpeg1.SaveToStream (Stream);
  65.       Stream.Position := 0;
  66.       Response.ContentType := 'image/jpeg';
  67.       Response.ContentStream := Stream;
  68.       Response.SendResponse;
  69.       // the response object will free the stream
  70.     finally
  71.       Jpeg1.Free;
  72.     end;
  73.   finally
  74.     Bitmap.Free;
  75.   end;
  76. end;
  77. end.