Solved

the image color depth

Posted on 2000-04-27
6
184 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
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

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…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
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…

706 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

16 Experts available now in Live!

Get 1:1 Help Now