Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

the image color depth

Posted on 2000-04-27
6
Medium Priority
?
206 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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
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 150 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

New feature and membership benefit!

New feature! Upgrade and increase expert visibility of your issues with Priority Questions.

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…
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…
Please read the paragraph below before following the instructions in the video — there are important caveats in the paragraph that I did not mention in the video. If your PaperPort 12 or PaperPort 14 is failing to start, or crashing, or hanging, …
Look below the covers at a subform control , and the form that is inside it. Explore properties and see how easy it is to aggregate, get statistics, and synchronize results for your data. A Microsoft Access subform is used to show relevant calcul…
Suggested Courses

877 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