Imagem No Grid

[VDLR]

Pessoal, será que alguém poderia me ajudar com esta procedure:

procedure TFRCadRim.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  If Column.Field = DMdados.TBCadRimFoto then
   Begin
    If not ( gdSelected in State ) then
     DBGrid1.Canvas.FillRect(Rect);
     With TPicture.Create do
     Begin
     Assign(DMdados.TBCadRimFoto);
     DBGrid1.Canvas.StretchDraw(Rect,Bitmap);
     Free;
    end;
end;
end;

O que estou querendo é que o grid mostre as imagens do banco em qualquer extensão (Jpeg, Bitmap, etc)

Se alguém sober, agradeço

Abraço

Valdecir

[Guest --Jonas --]

Pessoal, será que alguém poderia me ajudar com esta procedure:

procedure TFRCadRim.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  If Column.Field = DMdados.TBCadRimFoto then
   Begin
    If not ( gdSelected in State ) then
     DBGrid1.Canvas.FillRect(Rect);
     With TPicture.Create do
     Begin
     Assign(DMdados.TBCadRimFoto);
     DBGrid1.Canvas.StretchDraw(Rect,Bitmap);
     Free;
    end;
end;
end;

O que estou querendo é que o grid mostre as imagens do banco em qualquer extensão (Jpeg, Bitmap, etc)

Se alguém sober, agradeço

Abraço

Valdecir

Colega, dá uma olhada neste artigo, acho que vai te ajudar ...

http://www.activedelphi.com.br/modules.php...r=0&thold=0

[Micheus]

O que estou querendo é que o grid mostre as imagens do banco em qualquer extensão (Jpeg, Bitmap, etc)

você deve fazer o processo oposto ao que usou para gravar no banco.

Normalmente é utilizado stream: dá uma pesquisada aqui no forum por loadfrostream ou memorystream que já vai aparecer algo

[VDLR]

Micheus, obrigado pela atenção.

Cara na realidade as imagens aparecem no grid, mas só as que foram gravadas com a extensão Bitmap, as que foram gravadas como Jpeg não, alias da erro quando tem alguma imagem Jpeg.

Será que teria como alterar procedure para aparecer todas, já tentei e não consegui.

Abraços

Valdecir

[Micheus]

Cara na realidade as imagens aparecem no grid, mas só as que foram gravadas com a extensão Bitmap, as que foram gravadas como Jpeg não, alias da erro quando tem alguma imagem Jpeg.

Será que teria como alterar procedure para aparecer todas, já tentei e não consegui.

Voce não pode ter imagens de tipos diferentes armazenadas, e depois querer carregar ele como se fossem apenas BMP - não dá. O ideal é que sejam sempre gravadas com o mesmo tipo.

Bom, há meios de contornar. Voce lê a imagem do campo blob (se ele não for nulo) para um Tmemorystream, verifica os bytes iniciais (parte do header dos arquivos de imagem) para identificar o tipo de imagem que está lá.

Veja ref. para:

BMP: http://www.fastgraph.com/help/bmp_header_format.html

JPG: http://www.fastgraph.com/help/jpeg_header_format.html

Observe que os dois primeiros bytes (ou o primeiro word) identificam o tipo do arquivo.

Conforme a citação você deverá carregá-lo utilizando um TBitmap ou TJPGImage

Veja se isto vai funcionar, eu não testei:

function CarregaDBImagem(Campo :TBlobField; var Image :TGraphic) :boolean;
const
  BMP = word($4D42);
  JPG = word($FFD8);
var
  ImgSignature :Word;
  Stream :TMemoryStream;
begin
  Result := False;
  if not Campo.IsNull then
  begin
    if Assigned(Image) then  // só para o caso de algum esquecimento. ;-)
      FreeAndNil(Image);

    Stream := TMemoryStream.Create;
    try
      Campo.SaveToStream(Stream);
      Stream.Read(ImgSignature, 2); // lê 2 bytes
      if ImgSignature = JPG then
        Image := TJPEGImage.Create
      else
        if ImgSignature = BMP then
          Image := TBitmap.Create
        else
          Exit;

      try 
        Image.LoadFromStream(Stream);  // carrega imagem
        Result := True;  // apenas se não houver erro
      except
        Image.Free;
      end
    finally
      Stream.Free;
    end;
  end;
end;

para usar:

procedure TFRCadRim.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
  Img :TGraphic;
begin
  If Column.Field = DMdados.TBCadRimFoto then
  Begin
    If not (gdSelected in State) then
      DBGrid1.Canvas.FillRect(Rect);
    if CarregaDBImagem(DMdados.TBCadRimFoto, Img) then
    begin
      DBGrid1.Canvas.StretchDraw(Rect, Img);
      Img.Free; // libera objeto alocado na função
    end;
end;

Espero que funcione. :unsure:

[VDLR]

Micheus, muito obrigado pela atenção.

Cara deu pau.

Erro " Access violation at adress 00403480 in module 'ControleSMS.Exe'. Read of adress 0000014E "

Na realidade eu pensei nas duas extensões, pelo fato do usuária não ter que se preocupar com que extensão gravar, mas se conseguir mostrar só a Jpeg acho que tá bom.

Cara me ajuda

Abraço

Valdecir :(

[Micheus]

Micheus, muito obrigado pela atenção.

Cara deu pau.

Erro " Access violation at adress 00403480 in module 'ControleSMS.Exe'. Read of adress 0000014E "

eu vejo isto logo mais.

Na realidade eu pensei nas duas extensões, pelo fato do usuária não ter que se preocupar com que extensão gravar, mas se conseguir mostrar só a Jpeg acho que tá bom.

Neste caso, converte a imagem selecionada e salva no banco sempre um JPG.

Há uma tempilho eu coloquei uma função que faz isto --> post

Ao invés de gravar no disco, como no exemplo, você gravará no blob (como você já deve estar fazendo), mas sempre um JPG.

Daí não tem erro na hora de usar, você sabe que sempre tem um JPG no banco, além de que o espaço ocupado também será menor.

Veja se consegue adaptar a sua necessidade.

[VDLR]

Micheus desculpe a demora.

Cara achei legal o post para converter as imagens sempre num JPEG, porém não estou conseguindo usar pelo seguinte:

Quando eu salvo a imagem no banco eu uso o caminho do OpenPictureDialog

>>> DMdados.TBCadRimFoto.LoadFromFile(caminho);

A procedure que me traz este caminho, ficou assim com a função que peguei no post

procedure TFRinclrim.TabSheet2Show(Sender: TObject);
Var
 opd: TOpenPictureDialog;
begin
   opd := TOpenPictureDialog.Create(Application);
   if opd.Execute then
   Begin
    ImageJpg := TJPEGImage.Create;
     try
      if ConvertImage(opd.FileName, ImageJpg) then
      begin
      Image1.Picture.Assign(ImageJpg);
      caminho := opd.FileName;
      end;
      finally
      ImageJpg.Free;
      opd.Free;
    end;
  end;
end;

Não sei como pegar a imagem e salvar no banco, pois estou usando o LoadFromFile.

E quando salvo as imagens como Jpeg no banco da pau no grid

Abraços

Valdecir :( :(

[Guest --Jonas --]

Posso dar uma contribuição a sua duvida ????

Gravar imagem JPG em tabela Paradox

Procedure Grava_Imagem_JPEG(Tabela:TTable; Campo:TBlobField; 
Foto:TImage; Dialog:TOpenPictureDialog);
var 
  BS:TBlobStream;
  MinhaImagem:TJPEGImage;
Begin
  Dialog.InitialDir := 'c:\temp';
  Dialog.Execute;
  if Dialog.FileName <> '' Then
    Begin
    if not (Tabela.State in [dsEdit, dsInsert]) Then
      Tabela.Edit;
    BS := TBlobStream.Create((Campo as TBlobField), BMWRITE);
    MinhaImagem := TJPEGImage.Create;
    MinhaImagem.LoadFromFile(Dialog.FileName);
    MinhaImagem.SaveToStream(BS);
    Foto.Picture.Assign(MinhaImagem);
    BS.Free;
    MinhaImagem.Free;
    Tabela.Post;
    DBISaveChanges(Tabela.Handle);
  End;
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Grava_Imagem_JPEG(TbClientes,TbClientesCli_Foto, Image1, 
  OpenPictureDialog1);
// TbClientes é o nome de alguma Tabela
// TbClientesCli_Foto é um variavel da tabela do tipo Blob
// Image1 é um componente
// OpenPictureDialog1 é o componente para abrir a figura
end;

Editado Julho 24, 2007 por Micheus
Por gentileza, utilize identação para tornar a visualização melhor.

[Micheus]

Não sei como pegar a imagem e salvar no banco, pois estou usando o LoadFromFile.

você deve ter um campo blob para isso não?

Estou achando meio estranho que ao mostrar uma determinada guia (TabSheet) você esteja solicitando a seleção de uma foto, mas...

procedure TFRinclrim.TabSheet2Show(Sender: TObject);
Var
  BS :TBlobStream;
  opd: TOpenPictureDialog;
  ImageJpg :TJPEGImage;
begin
  opd := TOpenPictureDialog.Create(Application);
  if opd.Execute then
  Begin
    ImageJpg := TJPEGImage.Create;
    try
      if ConvertImage(opd.FileName, ImageJpg) then
      begin
       // aqui você está mostrando no seu TImage
        Image1.Picture.Assign(ImageJpg); 
      // a tabela TBCadRim deverá estar em modo edição ou inserção.
      // não sei como você está trabalhando, então, verifique e acrescente o Edit se necessário

      // aqui você cria o meio de transferir a imagem para o blob (campo)
        BS := TBlobStream.Create(DMdados.TBCadRimFoto, BMWRITE); 
      // aqui você transfere para o campo blob da sua tabela
        Image.Picture.Graphic.SaveToStream(BS);
      end;
    finally
      BS.Free;
      ImageJpg.Free;
      opd.Free;
    end;
  end;
end;

Veja se assim, você vai conseguir mover a imagem sem problemas.

p.s. Jonas, este BS eu não peguei do seu código não, foi de uma que captura imagem que postei no 4Share. ;)

[VDLR]

Micheus, mais um vez obrigado pela atenção.

Fiz as alterações, mas na hora de gravar recebo a seguinte mensagem de erro

INVALID CLASS TYPECAST

e aponta para esta linha do código

BS := TBlobStream.Create(DMdados.TBCadRimFoto, bmWrite);

Dá pra saber qual é o problema.

Abraço

Valdecir

[Micheus]

Fiz as alterações, mas na hora de gravar recebo a seguinte mensagem de erro

INVALID CLASS TYPECAST

e aponta para esta linha do código

BS := TBlobStream.Create(DMdados.TBCadRimFoto, bmWrite);

é erro na compilação certo?

Este tipo de mensagem é mais comum numa situação como a proposta pelo Jonas, onde você pode estar forçando uma determinada variável de um determinado tipo ser outro com o qual ela não é realmente compatível:

BS := TBlobStream.Create((Campo as TBlobField), BMWRITE);

Porque, se fosse uma questão de utilizar apenas um tipo impróprio na chamada do método Create, normalmente a mensagem seria referente a tipos incompativeis ou algo assim.

Qual o tipo de dados deste seu campo Foto na tabela TBCadRim?

Confirme também o tipo de field que foi incluso na tabela, ele deveria ser um TBlobField.

[VDLR]

Qual o tipo de dados deste seu campo Foto na tabela TBCadRim?

Confirme também o tipo de field que foi incluso na tabela, ele deveria ser um TBlobField.

Cara, fiz algumas alterações no projeto e as procedures ficaram assim:

public
  ImageJpg: TJPEGImage;
    { Public declarations }

function TFRinclrim.ConvertImage(SrcName :string; DstPic :TGraphic) :boolean;
var
  Picture :TPicture;
  ImageBMP :TBitmap;
begin
  Result := False;
  Picture := TPicture.Create;
  try
    Picture.LoadFromFile(SrcName);
    ImageBMP := TBitmap.Create;
    try
      ImageBMP.Width := Picture.Width;
      ImageBMP.Height := Picture.Height;
      ImageBMP.Canvas.Draw(0, 0, Picture.Graphic);
      DstPic.Assign(ImageBMP);
      Result := True;
    finally
      ImageBMP.Free;
    end;
  finally
    Picture.Free;
  end;
end;


procedure TFRinclrim.BTimageClick(Sender: TObject);
Var
 opd: TOpenPictureDialog;
begin
   opd := TOpenPictureDialog.Create(Application);
   if opd.Execute then
   Begin
    ImageJpg := TJPEGImage.Create;
     try
      if ConvertImage(opd.FileName, ImageJpg) then
      begin
      Image1.Picture.Assign(ImageJpg);
      end;
      finally
      ImageJpg.Free;
      opd.Free;
    end;
  end;
end;

procedure TFRinclrim.BTgravarClick(Sender: TObject);
var dia, mês, ano: Word;
    ano2 : String;
    BS: TBlobStream;
begin
  DecodeDate(Date, ano, mês, dia);
  ano2 := IntToStr(ano);
  DMdados.TBCadRim.Insert;
  DMdados.TBCadRimCadUsuario.Text := FRacesso.EDusuario.Text;
  DMdados.TBCadRimCodCliente.Text := EDcodigo.Text;
  DMdados.TBCadRimCliente.Text := EDrazaosocial.Text;
  DMdados.TBCadRimNrRim.Text := EDrim.Text +'/'+ano2;
  DMdados.TBCadRimContNrRim.Text := EDrim.Text;
  DMdados.TBCadRimMaterial.Text := EDmaterial.Text;
  DMdados.TBCadRimNotaFiscal.Text := EDnotafiscal.Text;
  DMdados.TBCadRimCertificadoNr.Text := EDcertifnr.Text;
  DMdados.TBCadRimOrdemServico.Text := EDordemserv.Text;
  DMdados.TBCadRimCorrida.Text := EDcorrida.Text;
  DMdados.TBCadRimPecaNr.Text := EDpecanr.Text;
  DMdados.TBCadRimTratTermSolic.Text := EDtratsolicit.Text;
  DMdados.TBCadRimNrPecaEnsaiada.Text := EDnrpcensaiadas.Text;
  DMdados.TBCadRimDurezaEspecif.Text := EDdurezaespecif.Text;
  DMdados.TBCadRimDurezaEncont.Text := EDdurezaencont.Text;
  DMdados.TBCadRimMetalogrSolicit.Text := EDmetalogrsolicit.Text;
  DMdados.TBCadRimMetalogrObtida.Text := EDmetalogrobtida.Text;
  DMdados.TBCadRimTamGraoSolicit.Text := EDtamgraosolicit.Text;
  DMdados.TBCadRimTamGraoObtida.Text := EDtamgraoobtido.Text;
  DMdados.TBCadRimObs.Text := EDobs.Text;
  DMdados.TBCadRimData.Text := DateToStr(DTPdata.Date);
  DMdados.TBCadRimDataCad.Text := FormatDateTime('dd/MM/yyyy',StrToDate(Edit1.Text));

  BS := TBlobStream.Create(DMdados.TBCadRimFoto, bmWrite);
  Image1.Picture.Graphic.SaveToStream(BS);

  DMdados.TBCadRim.Post;
  DMdados.TBCadRim.ApplyUpdates(-1);

end;

Porém ao clicar no botão gravar recebo o mesmo erro

INVALID CLASS TYPECAST

e aponta para esta linha do código

BS := TBlobStream.Create(DMdados.TBCadRimFoto, bmWrite);

O field é um TBlobField

Na uses para copilar coloquei >>> Jpeg, DBTables

Abraço

Valdecir ;)

Editado Julho 25, 2007 por Micheus

[Guest --Jonas --]

BS := TBlobStream.Create(DMdados.TBCadRimFoto, bmWrite);

Error 219 Invalid typecast

Erro 219 typecast inválido

Erro quando um typecast inválido é tentado em uma classe que o usa como o operador. Este erro também é reportado quando um objeto ou classe é typecast a uma classe inválida ou objeto e um método virtual daquela classe ou objeto é chamado. Este último erro só é descoberto se a opção -CR do compilador for usada.

Valdecir, o codigo que te mandei funciona perfeitamente no meu micro, no seu caso o erro pode estar justamente no campo da tabela TBCadRimFoto; este erro acontece se o campo não for realmente um TBlobField.

abraço.

[Micheus]

Error 219 Invalid typecast

Erro 219 typecast inválido

Erro quando um typecast inválido é tentado em uma classe que o usa como o operador. Este erro também é reportado quando um objeto ou classe é typecast a uma classe inválida ou objeto e um método virtual daquela classe ou objeto é chamado.

acho que foi mais ou menos isto que eu tinha dito...

no seu caso o erro pode estar justamente no campo da tabela TBCadRimFoto; este erro acontece se o campo não for realmente um TBlobField.

por isto do meu questionamento, o qual ele não respondeu... Daí fica difícil...

[VDLR]

Micheus e Jonas, muito obrigado pela atenção.

Pessoal a parte de gravar consegui resolver fazendo assim:

“ Parte da procedure “

  b:=TMemoryStream.Create;
  Image1.Picture.Graphic.SaveToStream(b);
  DMdados.TBCadRimFoto.LoadFromStream(b);
  DMdados.TBCadRim.Post;
  DMdados.TBCadRim.ApplyUpdates(-1);

Beleza converte a imagem e grava. Porém o grind com a imagem sendo um Jpeg não abre. Com a procedure assim

procedure TFRCadRim.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  If Column.Field = DMdados.TBCadRimFoto then
   Begin
    If not ( gdSelected in State ) then
     DBGrid1.Canvas.FillRect(Rect);
     With TPicture.Create do
     Begin
     Assign(DMdados.TBCadRimFoto);
     DBGrid1.Canvas.StretchDraw(Rect,Bitmap);
     Free;
    end;
end;
end;

Dá esse erro >>>> Bitmap image is not valid Desta forma com função que o Micheus criou

procedure TFRCadRim.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var Img :TGraphic;
begin
  If Column.Field = DMdados.TBCadRimFoto then
  Begin
    If not (gdSelected in State) then
     DBGrid1.Canvas.FillRect(Rect);
     if CarregaDBImagem(DMdados.TBCadRimFoto, Img) then
      begin
      DBGrid1.Canvas.StretchDraw(Rect,Img);
      Img.Free; // libera objeto alocado na função
   end;
  end;
end;

Dá este erro

>>>> Access Violation at address 00403598 in module ‘ControleSMS’

E aponta pra esta linha da procedure

if CarregaDBImagem(DMdados.TBCadRimFoto, Img) then

Será que tem como resolver isso ????

Abraço

Valdecir :unsure:

[Guest --Jonas --]

Ler imagem JPG da tabela Paradox

Procedure Le_Imagem_JPEG(Campo:TBlobField; Foto:TImage);
var BS:TBlobStream;
      MinhaImagem:TJPEGImage;
Begin
   if Campo.AsString <> '' Then
      Begin
         BS := TBlobStream.Create((Campo as TBlobField), BMREAD);
         MinhaImagem := TJPEGImage.Create;
         MinhaImagem.LoadFromStream(BS);
         Foto.Picture.Assign(MinhaImagem);
         BS.Free;
         MinhaImagem.Free;
     End
         Else Foto.Picture.LoadFromFile('c:\temp\limpa.jpg');
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
    Le_Imagem_JPEG(TbClientesCli_Foto, Image1);
// TbClientesCli_Foto é um variavel da tabela do tipo Blob
// Image1 é um componente
end;

[VDLR]

Jonas obrigado pela atenção, mas desta forma eu conseguiria visualizar a imagem no Timage.

Eu gostaria de ver a imagem no DBGrid.

Tem alguma idéia ?

por isto do meu questionamento, o qual ele não respondeu... Daí fica difícil...

Poxa Micheus desculpe, só agora caiu a ficha, o campo não é Blob e sim um MediumBlob do MySql ;)

Tem como eu ver estas imagens no DBGrid.

Abraço

Valdecir :(

[Guest --Jonas --]

Eu gostaria de ver a imagem no DBGrid.

então use um componente DBImage1.

[Micheus]

Tem como eu ver estas imagens no DBGrid.

VDLR, a melhor opção é você colocar um DBImage, como mencionou o Jonas. Nesta situação, a cada linha do DBGrid que é posicionada a imagem será alterada para o respectivo registro.

Mostrar a imagem no DBGrid convencional (componente distribuído com o Delphi) não seria viável porque a altura da linha é fixa (+/- 22pixels) e acredito que suas imagens necessitem de mais altura para uma boa visualização, certo?!

Bom, se for realmente necessário mostrar a imagem no grid, existe um componente free (com o código) - (DBGrid Plus), que permite alterações na altura da linha e está preparado para escrever campos memos em múltiplas linhas e imagens.

Porém, foi escrito para o Delphi 2 e prevendo seu uso de Paradox, já que ele espera o campo ftGraphic como campo de imagem.

Talvez você possa aproveitá-lo ou utilizar o código que ele usa para o desenho da imagem, em DrawColumnCell.

Se for adaptá-lo, como você estará gravando em seu banco imagens no formato JPG (que é o ideal), será necessário modificar o procedimento DrawColumnCell, substituindo o uso do objeto TBitmap por TJPGImage.

Abraços

[VDLR]

Micheus, tudo bem.

Cara mudei a procedure agora esta assim

 
procedure TFRCadRim.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var Bmp :TJPEGImage;
begin
   If Column.Field = DMdados.TBCadRimFoto then
   Begin
   Bmp := TJPEGImage.Create;
   If not ( gdSelected in State ) then
    DBGrid1.Canvas.FillRect(Rect);
     With TPicture.Create do
     Begin
     Bmp.Assign(DMdados.TBCadRimFoto);
     DBGrid1.Canvas.StretchDraw(Rect,Bmp);
     Free;
  end;
  Bmp.Free;
end;
end;

Porém recebo este erro

>>> Class EJPEG With Message ' Jpeg error #42'

Tu sabes o que pode ser ???

VDLR, a melhor opção é você colocar um DBImage, como mencionou o Jonas

O DBimage tambem só recebe Bitmap

Bom, se for realmente necessário mostrar a imagem no grid, existe um componente free (com o código) - (DBGrid Plus), que permite alterações na altura da linha e está preparado para escrever campos memos em múltiplas linhas e imagens.

Porém, foi escrito para o Delphi 2 e prevendo seu uso de Paradox, já que ele espera o campo ftGraphic como campo de imagem.

Dei uma olhada, mas não vi como adaptá-lo.

Cara se você tiver como ajudar agradeço.

Abraço

Valdecir :(

[Guest --Jonas --]

Ve se você consegue da internet o component TMultiImage, ele aceita quase todos os tipos de imagens , ve o que ele pode fazer:

*)
interface
(*
 Uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, FileCtrl, TMultiP, ComCtrls, Menus, Buttons, Resize;
*)


  Uses
    Windows,
    //Messages,
    SysUtils,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    TMultiP
   ;

Function ResizeImageBestFit(
  PMultiImage  : TPMultiImage;
  Height       : Integer;
  Width        : Integer): Boolean;

Function ResizeImageKeepProportions(
  PMultiImage  : TPMultiImage;
  NewDimension : Integer;
  IsWidth      : Boolean): Boolean;

Function IL_SaveAsDlg(
  PMultiImage : TPMultiImage;
  Quality     : Integer): Boolean;

Function IL_SaveAs(
  PMultiImage : TPMultiImage;
  inQuality   : Integer;
  sgFileName  : String;
  sgExt       : String;
  sgFileDir   : String): Boolean; OverLoad;

Function IL_SaveAs(
  PMultiImage : TPMultiImage;
  inQuality   : Integer;
  FileName    : String): Boolean; OverLoad;

implementation


//Unit Description UnitIndex Master Index

Function IL_SaveAs(
  PMultiImage : TPMultiImage;
  inQuality   : Integer;
  sgFileName  : String;
  sgExt       : String;
  sgFileDir   : String): Boolean;
Var
  sgFullFile  : String;
begin
  Try
    PMultiImage.JPegSaveQuality := inQuality;
    If Copy(sgFileDir,Length(sgFileDir),1) <> '\' Then
      sgFileDir := sgFileDir + '\';
    sgExt       := UpperCase(sgExt);
    sgFullFile  := sgFileDir + sgFileName;

    screen.cursor := crHourGlass;

    If sgExt = '.BMP'  Then PMultiImage.SaveAsBMP(sgFullFile);
    If sgExt = '.EPS'  Then PMultiImage.SaveAsEPS(sgFullFile);
    If sgExt = '.GIF'  Then PMultiImage.SaveAsGIF(sgFullFile);
    If sgExt = '.JPEG' Then PMultiImage.SaveAsJpg(sgFullFile);
    If sgExt = '.JPG'  Then PMultiImage.SaveAsJpg(sgFullFile);
    If sgExt = '.PCX'  Then PMultiImage.SaveAsPcx(sgFullFile);
    If sgExt = '.PNG'  Then PMultiImage.SaveAsPNG(sgFullFile);
    If sgExt = '.TGA'  Then PMultiImage.SaveAsTGA(sgFullFile);
    If sgExt = '.TIF'  Then PMultiImage.SaveAsTIF(sgFullFile);
    If sgExt = '.SCM'  Then PMultiImage.SaveCurrentMessage(sgFullFile);
    If sgExt = '.CMS'  Then PMultiImage.SaveCurrentCreditMessage(sgFullFile);
    PMultiImage.ImageName := sgFullFile;
    screen.cursor:=crDefault;
    Result := True;
  Except
    Result := False;
  End;
end;

//Unit Description UnitIndex Master Index

Function IL_SaveAsDlg(
  PMultiImage : TPMultiImage;
  Quality     : Integer): Boolean;
Var
  sgFileName : String;
  sgExt      : String;
  sgFileDir  : String;
  SaveDialog : TSaveDialog;
begin
  Result        := False;
  Try
    SaveDialog    := TSaveDialog.Create(nil);
    Try
      sgFileDir   := ExtractFileDir(PMultiImage.ImageName);
      If Copy(sgFileDir,Length(sgFileDir),1) <> '\' Then
        sgFileDir := sgFileDir + '\';
      sgFileName  := ExtractFileName(PMultiImage.ImageName);
      sgExt       := UpperCase(ExtractFileExt(sgFileName));
      SaveDialog.InitialDir := sgFileDir;
      If PMultiImage.BFileType = 'SCM' Then
      Begin
        SaveDialog.Filename:='*.SCM';
        SaveDialog.Filter:='Scroll message|*.scm';
      End
      Else
      Begin
        If PMultiImage.BFileType = 'CMS' Then
        Begin
          SaveDialog.Filename   := '*.CMS';
          SaveDialog.Filter     := 'Credit message|*.cms';
        End
        Else
        Begin
          SaveDialog.Filename   := sgFileName;
          SaveDialog.Filter     :='jpeg|*.jpg|bmp|*.bmp|gif|*.gif|pcx|*.pcx|png|*.png|tif|*.tif|tga|*.tga|eps|*.eps';
          If (sgExt = '.JPG') Or (sgExt = '.JPEG') Then SaveDialog.FilterIndex := 1;
          If (sgExt = '.BMP')  Then SaveDialog.FilterIndex := 2;
          If (sgExt = '.GIF')  Then SaveDialog.FilterIndex := 3;
          If (sgExt = '.PCX')  Then SaveDialog.FilterIndex := 4;
          If (sgExt = '.PNG')  Then SaveDialog.FilterIndex := 5;
          If (sgExt = '.TIF')  Then SaveDialog.FilterIndex := 6;
          If (sgExt = '.TIFF') Then SaveDialog.FilterIndex := 6;
          If (sgExt = '.TGA')  Then SaveDialog.FilterIndex := 7;
          If (sgExt = '.EPS')  Then SaveDialog.FilterIndex := 8;
        End;
      End;

      If SaveDialog.execute Then
      Begin
        sgFileDir   := ExtractFileDir(SaveDialog.FileName);
        If Copy(sgFileDir,Length(sgFileDir),1) <> '\' Then
          sgFileDir := sgFileDir + '\';
        sgFileName  := ExtractFileName(SaveDialog.FileName);
        sgExt       := UpperCase(ExtractFileExt(sgFileName));
        Result :=
          IL_SaveAs(
            PMultiImage, //PMultiImage : TPMultiImage;
            Quality    , //inQuality   : Integer;
            sgFileName , //sgFileName  : String;
            sgExt      , //sgExt       : String;
            sgFileDir  );//sgFileDir   : String): Boolean;
      End;
    Finally
      SaveDialog.Free;
    End;
  Except
  End;
end;

//Unit Description UnitIndex Master Index

Function ResizeImageKeepProportions(
  PMultiImage  : TPMultiImage;
  NewDimension : Integer;
  IsWidth      : Boolean): Boolean;
Var
  inWidthOld   : Integer;
  inWidthNew   : Integer;
  inHeightOld  : Integer;
  inHeightNew  : Integer;
  Bitmap       : TBitmap;
  boStretch    : Boolean;
begin
  boStretch:= PMultiImage.StretchRatio;
  Bitmap       := TBitmap.Create;
  Try
    Try
      {Set Stretch Off}
      PMultiImage.StretchRatio := False;
      {Create a new bitmap and set its size}
      inWidthOld  := PMultiImage.Picture.Bitmap.Width;
      inHeightOld := PMultiImage.Picture.Bitmap.Height;
      If IsWidth Then
      Begin
       inWidthNew  := NewDimension;
       inHeightNew := (inHeightOld * inWidthNew) div inWidthOld;
      End
      Else
      Begin
        inHeightNew := NewDimension;
        inWidthNew  := (inWidthOld * inHeightNew) div inHeightOld;
      End;
      Bitmap.Width  := inWidthNew;
      Bitmap.Height := inHeightNew;
      {Copy the palette}
      Bitmap.Palette:=PMultiImage.Picture.Bitmap.Palette;
      {Delete the lines needed to shrink}
      SetStretchBltMode(Bitmap.Canvas.Handle,STRETCH_DELETESCANS);
      {Resize it}
      Bitmap.Canvas.Copyrect(Rect(0,
                                 0,
                                 inWidthNew,
                                 inHeightNew),
                            PMultiImage.Picture.Bitmap.Canvas,
                            Rect(0,
                                 0,
                                 PMultiImage.Picture.Bitmap.Width,
                                 PMultiImage.Picture.Bitmap.Height));
      {Copy the palette}
      Bitmap.Palette:=PMultiImage.Picture.Bitmap.Palette;
      {Assign the new smaller bitmap}
      PMultiImage.Picture.Bitmap.Assign(Bitmap);
      {Free the bitmap}

      Result := True;
    Except
      Result := False;
    End;
  Finally
    Bitmap.Free;
    PMultiImage.StretchRatio := boStretch;
  End;
end;

//Unit Description UnitIndex Master Index

Function ResizeImageBestFit(
  PMultiImage  : TPMultiImage;
  Height       : Integer;
  Width        : Integer): Boolean;
Var
  inWidthOld   : Integer;
  inHeightOld  : Integer;
  boStretch    : Boolean;
  IsWidth      : Boolean;
  NewDimension : Integer;
begin
  boStretch    := PMultiImage.StretchRatio;
  Try
    Try
      PMultiImage.StretchRatio := False;
      inWidthOld  := PMultiImage.Picture.Bitmap.Width;
      inHeightOld := PMultiImage.Picture.Bitmap.Height;
      IsWidth     := (((inHeightOld * Width) div inWidthOld)<=Height);
      If IsWidth Then
      Begin
        NewDimension := Width;
      End
      Else
      Begin
        NewDimension := Height;
      End;
      Result :=
        ResizeImageKeepProportions(
          PMultiImage  ,  //PMultiImage  : TPMultiImage;
          NewDimension ,  //NewDimension : Integer;
          IsWidth      ); //IsWidth      : Boolean): Boolean;
    Except
      Result := False;
    End;
  Finally
    PMultiImage.StretchRatio := boStretch;
  End;
end;

//Unit Description UnitIndex Master Index

Function IL_SaveAs(
  PMultiImage : TPMultiImage;
  inQuality   : Integer;
  FileName    : String): Boolean; OverLoad;
Var
  sgFileName  : String;
  sgExt       : String;
  sgFileDir   : String;
Begin
  sgFileName  := ExtractFileName(FileName);
  sgExt       := ExtractFileExt(FileName);
  sgFileDir   := ExtractFileDir(FileName);
  Result :=
    IL_SaveAs(
      PMultiImage ,  //PMultiImage : TPMultiImage;
      inQuality   ,  //inQuality   : Integer;
      sgFileName  ,  //sgFileName  : String;
      sgExt       ,  //sgExt       : String;
      sgFileDir   ); //sgFileDir   : String): Boolean; OverLoad;
End;

end.