Redimensionar foto e compactar

04/02/2009

0

Bom dia a todos,

Preciso do seguinte:
Quando a pessoa procurar uma foto no computador para adicionar no cadastro, o software precisa redimensionar o tamanho da foto e compactar. Está acontecendo que alguns clientes do software selecionam fotos com 1, 2,3 MB de tamanho.

Se alguém souber de uma rotina assim, ou quiser vender uma rotina assim, entre em contato: luis_erucci@yahoo.com.br

Abraços!!


Erucci

Erucci

Responder

Post mais votado

04/02/2009

Função para redimensionar a image:

function PadronizaTamanho(Imagem: TGraphic; W, H: Integer;
  Tipo: TGraphicClass): TGraphic;
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.Width := W;
    B.Height := H;
    B.Canvas.StretchDraw(Rect(0, 0, W, H), Imagem);
    if Tipo = nil
    then
      Result := TGraphic(Imagem.ClassType.Create)
    else
      Result := Tipo.Create;
    Result.Assign ( B ) ;
  finally
    B.Free;
  end;
end;


Função para salvar em JPG:

procedure SalvarImageBanco(Field: tField; Image: tImage);
var
  jpg:TJPEGImage;
begin
  Try
  if Image.Picture <> nil then
  begin
    Try
      Jpg := TJPEGImage.Create;
      Jpg.Assign(Image.Picture);
      Jpg.CompressionQuality := 50;
      jpg.Compress;
      Jpg.SaveToFile(´Tmp.jpg´);
      if FileExists(´Tmp.jpg´) then
      begin
        TBlobField(Field).LoadFromFile(´Tmp.jpg´);
      end
      else
      begin
        Field.Clear;
      end;
    Finally
      Jpg.Free;
      DeleteFile(´Tmp.jpg´)
    End;
  end
  else
  begin
    Field.Clear;
  end;
  Except
    Field.Clear;

  End;
end;


Rotina par abrir a imagem do banco para um TImage

procedure AbrirImageBanco(Field: tField; Image: tImage);
var
  Stm: TStream;
  Jpg: TJPEGImage;
  res: TResourceStream;//Classe específica  do Delphi
                       //para manipulação de recursos

begin
  with Field do
  try
    if TBlobField(Field).BlobSize > 0 then
    begin
      try
        Stm := TMemoryStream.Create;
        Jpg := TJpegImage.Create;
        TBlobField(Field).SaveToStream(Stm);
        Stm.Position := 0;
        Jpg.LoadFromStream(Stm);
        try
          Image.Picture.Assign(Jpg);
          Image.Tag := 0;
        except   
          Image.Picture.Assign(Nil);
        end;
      finally
        Stm.Free;
        Jpg.Free;
      end;
    end
    else
    begin
      Try
        Jpg := TJpegImage.Create;
        Res := TResourceStream.Create(Hinstance, ´SEMIMAGEM´, ´JPGFILE´);
        Res.SaveToFile(´tmp.jpg´);
        jpg.LoadFromFile(´tmp.jpg´);
        Image.Picture.Assign(Jpg);
        Image.Tag := 1;
      Finally
        DeleteFile(´tmp.jpg´);
        Jpg.Free;
        Res.Free;
      End;
      //Image.Picture.Assign(nil);
    end;
  except
    // controle de erro
  end;
end;


PS : Nessa rotina eu utilizo um arquivo *.res com uma imagem para mostrar que o item não possui imagem.

Rotina que para abrir imagem do arquivo para um TImage

procedure AbrirImageOpenPicutre(OpenPicture: TOpenPictureDialog;
  Image: tImage);
var
  jpg:TJPEGImage;
begin
  if OpenPicture.Execute then
  begin
    Try
      jpg := TJPEGImage.Create;
      jpg.LoadFromFile(OpenPicture.FileName);


      if (jpg.Width > 128) or (jpg.Height > 128) then
      begin
        //ShowMessage(´A imagem tem que ter tamanho igual ou menor a 128x128 pixels.´);
        //exit;
        PadronizaTamanho(Jpg,128,128,TJPEGImage);
      end;
      Image.Picture.Assign(jpg);
      Image.Tag := 0;
    Finally
      jpg.Free;
    End;
  end;
end;


Acho que talvez de para você adaptar essas rotinas para seu caso.


Vitor Alcantara

Vitor Alcantara
Responder

Mais Posts

04/02/2009

Rodc

Não lembro bem como se faz, mas segue aí a teoria que deve funcionar...

Carrege a foto em um TImage com o tamanho que deseja e com a propriedade Stretch como True. Depois pegue o Canvas do TImage, coloque em um TBitmap e salve convertendo para JPG. Procure na internet o código que converte para JPG.
Qualquer dúvida posta aqui que vou tentar ajudá-lo


Responder

04/02/2009

Erucci

Obrigado amigos, valew, vou testar!!!!! Abraços!! Sucesso para vocês!!! :D


Responder

Assista grátis a nossa aula inaugural

Assitir aula

Saiba por que programar é uma questão de
sobrevivência e como aprender sem riscos

Assistir agora

Utilizamos cookies para fornecer uma melhor experiência para nossos usuários, consulte nossa política de privacidade.

Aceitar