Solved

the image color depth

Posted on 2000-04-27
6
185 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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

The uses clause is one of those things that just tends to grow and grow. Most of the time this is in the main form, as it's from this form that all others are called. If you have a big application (including many forms), the uses clause in the in…
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…
Concerto provides fully managed cloud services and the expertise to provide an easy and reliable route to the cloud. Our best-in-class solutions help you address the toughest IT challenges, find new efficiencies and deliver the best application expe…

932 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now