Solved

the image color depth

Posted on 2000-04-27
6
187 Views
Last Modified: 2010-04-04
hello... i have made counter in cgi..
bet the problem is that, i can't set smaller size for images

the code is
..............................
unit cgi_images;

interface

uses
  Windows, Messages, SysUtils, Classes, HTTPApp, ExtCtrls, Jpeg, Graphics, Inifiles, Forms;

type
  TWebModule1 = class(TWebModule)
    PageProducer1: TPageProducer;
    procedure WebModule1WebActionItem1Action(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  WebModule1: TWebModule1;

implementation

{$R *.DFM}


procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

var Stream: TMemoryStream;
    Pic : TImage;
begin

{ create stream }
  Stream := TMemoryStream.Create;

{ making picture}
  Pic := TImage.Create(self);
  Pic.Width := 60;
  Pic.Height := 16;

  Pic.Canvas.Font.Color := clBlack;
//Pic.Picture.Bitmap.PixelFormat
  Pic.Canvas.TextOut(2,2,'ok 123..');
  Pic.Picture.Graphic.SaveToStream(stream);

{ Sending image }
  Response.ContentType := 'image/gif';
  Stream.Position := 0;
  Response.ContentStream := Stream;
  Response.SendResponse;

{ Handled := True;}
  Stream.Free;

end;


end.


..........
ie triedo to do something with
Pic.Picture.Bitmap.PixelFormat

but no success:((
please, help me.
Sandis.
0
Comment
Question by:sviksna
  • 3
  • 3
6 Comments
 
LVL 4

Expert Comment

by:Radler
ID: 2757675
Hi sviksna,

Here is a complete code( auh ! by 50 points !!) .
At your code a Graphic <> Gif data, if really desired a gif image replace the TJPEGImage to TGifImage class below.

Some methods must be ignored, because they are inside Reg32 and/or Str_Pas, but your names are sugests.

T++, Radler.

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, HTTPApp, Graphics, JPeg, Math;

type
  TMainWebMod = class(TWebModule)
       procedure MainWebModSendNumImgAction( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                               var Handled: Boolean);
       procedure WebModuleAfterDispatch( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                         var Handled: Boolean);
  private
       { Private declarations }
       Strm : TMemoryStream;
       function ProcessCountID( CounterName : string) : integer;
       procedure SetErrorImage(const Value: string);
       function GetErrorImage: string;
       procedure SetCountValue( const CountName : string; Value : integer );
  public
       { Public declarations }
       property ErrorImage : string read GetErrorImage write SetErrorImage;
       procedure LoadImgNames( Num : integer; const RootDir : string; List : TStringList ); //Cria lista da arquvos para serem carregados
       procedure MountJPGImage( List : TStringList; OutImg : TBitMap );
       procedure GetNumberImg( Num : integer; OutImg : TJPEGImage );
       procedure SendErrorImg( Response : TWebResponse );
  end;

var
  MainWebMod: TMainWebMod;

implementation

{$R *.DFM}

uses
      Str_Pas, Reg32;


const
      _REG_PATH_            =      'HKEY_LOCAL_MACHINE\Software\ARS\Roger\WebCounter';
      _DEF_ERROR_IMG_      =      'V:\Paginas HTML\contador\ERROR.JPG' ;

procedure TMainWebMod.GetNumberImg(Num: integer; OutImg : TJPEGImage);
{-------------------------------------------------------------------------------------------------------------}
var
      List : TStringList;
      IBmp : TBitMap;
begin
      List:=TStringList.Create;
      IBmp:=TBitMap.Create;
      try
            Self.LoadImgNames( Num, 'V:\Paginas HTML\contador\', List );
            Self.MountJPGImage( List, IBmp );
            OutImg.Assign( IBmp );
      finally
            List.Free;
            IBmp.Free;
      end;
end;

procedure TMainWebMod.LoadImgNames(Num: integer; const RootDir: string; List: TStringList);
{-------------------------------------------------------------------------------------------------------------}
//Cria lista da arquvos para serem carregados
var
      Rest, Calc : integer;
begin
      List.Clear;
      Calc:=Num;
      repeat
            Rest:=Calc mod 10;
            Calc:=Calc div 10;
            List.Add( Rootdir + 'n' + IntToStr( Rest ) + '.jpg' );
      until Calc = 0;
end;

procedure TMainWebMod.MountJPGImage(List: TStringList; OutImg: TBitMap);
{-------------------------------------------------------------------------------------------------------------}
var
      TmpBmp : TBitMap;
      TmpImg : TJPEGImage;
      Rc : TRect;
      MaxH, AccW, i : integer;
      Ofx : integer;
begin
      i:=0;
      MaxH:=0;
      AccW:=0;

      //Carrega todas as imagens e calcula dimensoes
      TmpImg:=TJPEGImage.Create; //Figura de carga
      repeat
            try
                  TmpBmp:=TBitMap.Create; //Figura de transferencia
                  TmpImg.LoadFromFile( List.Strings[i] );
                  TmpBmp.Assign( TmpImg );
                  List.Objects[i]:=TmpBmp; //Salva imagem
                  MaxH:=Max(TmpBmp.Height, MaxH );
                  Inc( AccW , TmpBmp.Width );
            except
                  List.Delete(i);
                  System.Continue;
            end;
            Inc( i );
      until (i >= List.Count);
      TmpImg.Free;

      //Transfere imagens para saida
      OutImg.Width:=AccW;
      OutImg.Height:=MaxH;
      OfX:=OutImg.Width;
      for i:=0 to (List.Count-1) do begin
            try
                  Rc:=Rect(Ofx - TBitMap(List.Objects[i]).Width,0, Ofx,OutImg.Height );
                  OutImg.Canvas.CopyRect( Rc, TBitMap(List.Objects[i]).Canvas, TBitMap(List.Objects[i]).Canvas.ClipRect );
            except
                  //Nada
            end;
            Dec( Ofx, TBitMap(List.Objects[i]).Width);
      end;
      //Liberar objetos da lista de nomes / imagens
      for i:=List.Count-1 downto 0 do begin
            TBitMap(List.Objects[i]).Free; //Libera imagem
      end;
end;

procedure TMainWebMod.MainWebModSendNumImgAction( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                                           var Handled: Boolean);
{-------------------------------------------------------------------------------------------------------------}
var
      CountID : integer;
      Img : TJPEGImage;
      CounterName : string;
begin
      try
            //Pega nome do contador
            CounterName:=Request.QueryFields.Values[ 'countername' ];
            if CounterName = EmptyStr then begin
                  SendErrorImg( Response );
                  Exit;
            end;

            //Checa se ha setvalue ##alteraca do valor
            if Request.QueryFields.Values[ 'set' ] <> EmptyStr then begin
                  try
                        CountID:=StrToInt( Request.QueryFields.Values[ 'set' ] );
                  except
                        SendErrorImg( Response );
                        Exit; //Cancela atualizacao
                  end;
                  Self.SetCountValue( CounterName , CountID )
            end;

            //Pega valor apos ter incrementado anterior
            CountID:=ProcessCountID( CounterName );
            if CountID <> 0 then begin
                  Img:=TJPEGImage.Create;
                  try
                        Self.GetNumberImg( CountId, Img );
                        Strm:=TMemoryStream.Create;
                        try
                              Img.SaveToStream( Strm );
                              Strm.Position:=0;
                              Response.ContentType:='image/jpeg';
                              Response.ContentStream:=Strm;
                              Response.SendResponse;
                        finally
                              //Nao liberar o streamer aqui isso sera feito apos dispatch !!!!!!!!!!!!!
                        end;
                  finally
                        Img.Free;
                  end;
            end else begin
                  //Falha no processo deve ser informada com grafico correlato
                  Self.SendErrorImg( Response );
            end;
      finally
            Handled:=True;
      end;
end;

function TMainWebMod.ProcessCountID( CounterName : string): integer;
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            Reg.LazyWrite:=False;
            try
                  if not Reg.ReadFullInteger(_REG_PATH_ + '\'+ CounterName, Result) then begin
                        Result:=0;
                        Reg.WriteFullInteger(_REG_PATH_ + '\'+ CounterName, Result, True );
                  end;
            except
                  Result:=0;
                  Reg.WriteFullInteger(_REG_PATH_ + '\' + CounterName, Result, True );
            end;
            Inc( Result );
            Reg.WriteFullInteger(_REG_PATH_ + '\'+ CounterName, Result, True );
      finally
            Reg.Free;
      end;
end;

procedure TMainWebMod.SendErrorImg(Response: TWebResponse);
{-------------------------------------------------------------------------------------------------------------}
var
      BufferImg : TJpegImage;
begin
      BufferImg:=TJPEGImage.Create;
      try
            BufferImg.LoadFromfile( ErrorImage ); //Carrega imagem de erro
            try
                  BufferImg.SaveToStream( Strm );
                  Strm.Position:=0;
                  Response.ContentType := 'image/jpeg';
                  Response.ContentStream := Strm;
                  Response.SendResponse;
            finally
                  //!!!!! Nao liberar o streamer para processo apos finalizar dispacho
            end;
      finally
            BufferImg.Free;
      end;
end;

procedure TMainWebMod.SetErrorImage(const Value: string);
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            Reg.WriteFullString( _REG_PATH_ + '\'+ 'ErrorImage', Value, True );
      finally
            Reg.Free;
      end;
end;

function TMainWebMod.GetErrorImage: string;
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            try
                  Reg.ReadFullString( _REG_PATH_ + 'ErrorImage', Result );
            except
                  Reg.WriteFullString( _REG_PATH_ + 'ErrorImage', _DEF_ERROR_IMG_, True );
            end;
      finally
            Reg.Free;
      end;
end;

procedure TMainWebMod.SetCountValue(const CountName: string; Value: integer);
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            Reg.OpenFullKey( _REG_PATH_, True );
            Reg.WriteInteger( CountName , Value );
      finally
            Reg.Free;
      end;
end;

procedure TMainWebMod.WebModuleAfterDispatch( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                                     var Handled: Boolean);
{-------------------------------------------------------------------------------------------------------------}
begin
      if Assigned( Strm ) then begin
            Strm.Free;
      end;
end;

end.
0
 
LVL 4

Expert Comment

by:Radler
ID: 2757676
Hi sviksna,

Here is a complete code( auh ! by 50 points !!) .
At your code a Graphic <> Gif data, if really desired a gif image replace the TJPEGImage to TGifImage class below.

Some methods must be ignored, because they are inside Reg32 and/or Str_Pas, but your names are sugests.

T++, Radler.

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, HTTPApp, Graphics, JPeg, Math;

type
  TMainWebMod = class(TWebModule)
       procedure MainWebModSendNumImgAction( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                               var Handled: Boolean);
       procedure WebModuleAfterDispatch( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                         var Handled: Boolean);
  private
       { Private declarations }
       Strm : TMemoryStream;
       function ProcessCountID( CounterName : string) : integer;
       procedure SetErrorImage(const Value: string);
       function GetErrorImage: string;
       procedure SetCountValue( const CountName : string; Value : integer );
  public
       { Public declarations }
       property ErrorImage : string read GetErrorImage write SetErrorImage;
       procedure LoadImgNames( Num : integer; const RootDir : string; List : TStringList ); //Cria lista da arquvos para serem carregados
       procedure MountJPGImage( List : TStringList; OutImg : TBitMap );
       procedure GetNumberImg( Num : integer; OutImg : TJPEGImage );
       procedure SendErrorImg( Response : TWebResponse );
  end;

var
  MainWebMod: TMainWebMod;

implementation

{$R *.DFM}

uses
      Str_Pas, Reg32;


const
      _REG_PATH_            =      'HKEY_LOCAL_MACHINE\Software\ARS\Roger\WebCounter';
      _DEF_ERROR_IMG_      =      'V:\Paginas HTML\contador\ERROR.JPG' ;

procedure TMainWebMod.GetNumberImg(Num: integer; OutImg : TJPEGImage);
{-------------------------------------------------------------------------------------------------------------}
var
      List : TStringList;
      IBmp : TBitMap;
begin
      List:=TStringList.Create;
      IBmp:=TBitMap.Create;
      try
            Self.LoadImgNames( Num, 'V:\Paginas HTML\contador\', List );
            Self.MountJPGImage( List, IBmp );
            OutImg.Assign( IBmp );
      finally
            List.Free;
            IBmp.Free;
      end;
end;

procedure TMainWebMod.LoadImgNames(Num: integer; const RootDir: string; List: TStringList);
{-------------------------------------------------------------------------------------------------------------}
//Cria lista da arquvos para serem carregados
var
      Rest, Calc : integer;
begin
      List.Clear;
      Calc:=Num;
      repeat
            Rest:=Calc mod 10;
            Calc:=Calc div 10;
            List.Add( Rootdir + 'n' + IntToStr( Rest ) + '.jpg' );
      until Calc = 0;
end;

procedure TMainWebMod.MountJPGImage(List: TStringList; OutImg: TBitMap);
{-------------------------------------------------------------------------------------------------------------}
var
      TmpBmp : TBitMap;
      TmpImg : TJPEGImage;
      Rc : TRect;
      MaxH, AccW, i : integer;
      Ofx : integer;
begin
      i:=0;
      MaxH:=0;
      AccW:=0;

      //Carrega todas as imagens e calcula dimensoes
      TmpImg:=TJPEGImage.Create; //Figura de carga
      repeat
            try
                  TmpBmp:=TBitMap.Create; //Figura de transferencia
                  TmpImg.LoadFromFile( List.Strings[i] );
                  TmpBmp.Assign( TmpImg );
                  List.Objects[i]:=TmpBmp; //Salva imagem
                  MaxH:=Max(TmpBmp.Height, MaxH );
                  Inc( AccW , TmpBmp.Width );
            except
                  List.Delete(i);
                  System.Continue;
            end;
            Inc( i );
      until (i >= List.Count);
      TmpImg.Free;

      //Transfere imagens para saida
      OutImg.Width:=AccW;
      OutImg.Height:=MaxH;
      OfX:=OutImg.Width;
      for i:=0 to (List.Count-1) do begin
            try
                  Rc:=Rect(Ofx - TBitMap(List.Objects[i]).Width,0, Ofx,OutImg.Height );
                  OutImg.Canvas.CopyRect( Rc, TBitMap(List.Objects[i]).Canvas, TBitMap(List.Objects[i]).Canvas.ClipRect );
            except
                  //Nada
            end;
            Dec( Ofx, TBitMap(List.Objects[i]).Width);
      end;
      //Liberar objetos da lista de nomes / imagens
      for i:=List.Count-1 downto 0 do begin
            TBitMap(List.Objects[i]).Free; //Libera imagem
      end;
end;

procedure TMainWebMod.MainWebModSendNumImgAction( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                                           var Handled: Boolean);
{-------------------------------------------------------------------------------------------------------------}
var
      CountID : integer;
      Img : TJPEGImage;
      CounterName : string;
begin
      try
            //Pega nome do contador
            CounterName:=Request.QueryFields.Values[ 'countername' ];
            if CounterName = EmptyStr then begin
                  SendErrorImg( Response );
                  Exit;
            end;

            //Checa se ha setvalue ##alteraca do valor
            if Request.QueryFields.Values[ 'set' ] <> EmptyStr then begin
                  try
                        CountID:=StrToInt( Request.QueryFields.Values[ 'set' ] );
                  except
                        SendErrorImg( Response );
                        Exit; //Cancela atualizacao
                  end;
                  Self.SetCountValue( CounterName , CountID )
            end;

            //Pega valor apos ter incrementado anterior
            CountID:=ProcessCountID( CounterName );
            if CountID <> 0 then begin
                  Img:=TJPEGImage.Create;
                  try
                        Self.GetNumberImg( CountId, Img );
                        Strm:=TMemoryStream.Create;
                        try
                              Img.SaveToStream( Strm );
                              Strm.Position:=0;
                              Response.ContentType:='image/jpeg';
                              Response.ContentStream:=Strm;
                              Response.SendResponse;
                        finally
                              //Nao liberar o streamer aqui isso sera feito apos dispatch !!!!!!!!!!!!!
                        end;
                  finally
                        Img.Free;
                  end;
            end else begin
                  //Falha no processo deve ser informada com grafico correlato
                  Self.SendErrorImg( Response );
            end;
      finally
            Handled:=True;
      end;
end;

function TMainWebMod.ProcessCountID( CounterName : string): integer;
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            Reg.LazyWrite:=False;
            try
                  if not Reg.ReadFullInteger(_REG_PATH_ + '\'+ CounterName, Result) then begin
                        Result:=0;
                        Reg.WriteFullInteger(_REG_PATH_ + '\'+ CounterName, Result, True );
                  end;
            except
                  Result:=0;
                  Reg.WriteFullInteger(_REG_PATH_ + '\' + CounterName, Result, True );
            end;
            Inc( Result );
            Reg.WriteFullInteger(_REG_PATH_ + '\'+ CounterName, Result, True );
      finally
            Reg.Free;
      end;
end;

procedure TMainWebMod.SendErrorImg(Response: TWebResponse);
{-------------------------------------------------------------------------------------------------------------}
var
      BufferImg : TJpegImage;
begin
      BufferImg:=TJPEGImage.Create;
      try
            BufferImg.LoadFromfile( ErrorImage ); //Carrega imagem de erro
            try
                  BufferImg.SaveToStream( Strm );
                  Strm.Position:=0;
                  Response.ContentType := 'image/jpeg';
                  Response.ContentStream := Strm;
                  Response.SendResponse;
            finally
                  //!!!!! Nao liberar o streamer para processo apos finalizar dispacho
            end;
      finally
            BufferImg.Free;
      end;
end;

procedure TMainWebMod.SetErrorImage(const Value: string);
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            Reg.WriteFullString( _REG_PATH_ + '\'+ 'ErrorImage', Value, True );
      finally
            Reg.Free;
      end;
end;

function TMainWebMod.GetErrorImage: string;
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            try
                  Reg.ReadFullString( _REG_PATH_ + 'ErrorImage', Result );
            except
                  Reg.WriteFullString( _REG_PATH_ + 'ErrorImage', _DEF_ERROR_IMG_, True );
            end;
      finally
            Reg.Free;
      end;
end;

procedure TMainWebMod.SetCountValue(const CountName: string; Value: integer);
{-------------------------------------------------------------------------------------------------------------}
var
      Reg : TRegistryNT;
begin
      Reg:=TRegistryNT.Create;
      try
            Reg.OpenFullKey( _REG_PATH_, True );
            Reg.WriteInteger( CountName , Value );
      finally
            Reg.Free;
      end;
end;

procedure TMainWebMod.WebModuleAfterDispatch( Sender: TObject; Request: TWebRequest; Response: TWebResponse;
                                                                     var Handled: Boolean);
{-------------------------------------------------------------------------------------------------------------}
begin
      if Assigned( Strm ) then begin
            Strm.Free;
      end;
end;

end.
0
 
LVL 1

Author Comment

by:sviksna
ID: 2759434
Sorry,
Are u telling me that there is source for counter, but u can't offer nothing better than Tjpeg image? (I already had it... i just wanted to set colors from 16bit to some lover number, for sample 256 or 16. That was my point, not the rutine how to build counter trought registry or INI files or Databases... i was asking for methods, how to get more smaler image in size image )


so?!?
0
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 1

Author Comment

by:sviksna
ID: 2759444
Sorry,
Are u telling me that there is source for counter, but u can't offer nothing better than Tjpeg image? (I already had it... i just wanted to set colors from 16bit to some lover number, for sample 256 or 16. That was my point, not the rutine how to build counter trought registry or INI files or Databases... i was asking for methods, how to get more smaler image in size image )


so?!?
0
 
LVL 4

Accepted Solution

by:
Radler earned 50 total points
ID: 2769241
Scrambled in my comment I said about TGifImage.
Try get the RX Library to deal with gifs or
http://www.melander.dk/delphi/index.html
( remember about Unisys copyrigths ).

The components have the SaveToStream method too.


T++, Radler.
0
 
LVL 1

Author Comment

by:sviksna
ID: 2769430
Ok. Thnx.
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
This video shows how to quickly and easily add an email signature for all users on Exchange 2016. The resulting signature is applied on a server level by Exchange Online. The email signature template has been downloaded from: www.mail-signatures…

789 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question