Estas funções eu tenho guardadas mas nunca usei:
--------------------
type
TRGBArray = array[Word] of TRGBTriple;
pRGBArray = ^TRGBArray;
procedure SmoothResize(Src, Dst: TBitmap);
var
x, y: Integer;
xP, yP: Integer;
xP2, yP2: Integer;
SrcLine1, SrcLine2: pRGBArray;
t3: Integer;
z, z2, iz2: Integer;
DstLine: pRGBArray;
DstGap: Integer;
w1, w2, w3, w4: Integer;
begin
Src.PixelFormat := pf24Bit;
Dst.PixelFormat := pf24Bit;
if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then
Dst.Assign(Src)
else
begin
DstLine := Dst.ScanLine[0];
DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine);
xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
yP := 0;
for y := 0 to pred(Dst.Height) do
begin
xP := 0;
SrcLine1 := Src.ScanLine[yP shr 16];
if (yP shr 16 < pred(Src.Height)) then
SrcLine2 := Src.ScanLine[succ(yP shr 16)]
else
SrcLine2 := Src.ScanLine[yP shr 16];
z2 := succ(yP and $FFFF);
iz2 := succ((not yp) and $FFFF);
for x := 0 to pred(Dst.Width) do
begin
t3 := xP shr 16;
z := xP and $FFFF;
w2 := MulDiv(z, iz2, $10000);
w1 := iz2 - w2;
w4 := MulDiv(z, z2, $10000);
w3 := z2 - w4;
DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
SrcLine1[t3 + 1].rgbtRed * w2 +
SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;
DstLine[x].rgbtGreen :=
(SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +
SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr
16;
DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
SrcLine1[t3 + 1].rgbtBlue * w2 +
SrcLine2[t3].rgbtBlue * w3 +
SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;
Inc(xP, xP2);
end; {for}
Inc(yP, yP2);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end; {for}
end; {if}
end; {SmoothResize}
function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string):
Boolean;
var
JPEGImage: TJPEGImage;
begin
result := true;
if (FileName = '') then // No FileName so nothing
Result := False //to load - return False...
else
begin
try // Start of try except
JPEGImage := TJPEGImage.Create; // Create the JPEG image... try //
now
try // to load the file but
JPEGImage.LoadFromFile(FilePath + FileName);
// might fail...with an Exception.
Bitmap.Assign(JPEGImage);
// Assign the image to our bitmap.Result := True;
// Got it so return True.
finally
JPEGImage.Free; // ...must get rid of the JPEG image. finally
end; {try}
except
Result := False; // Oops...never Loaded, so return False.
end; {try}
end; {if}
end; {LoadJPEGPictureFile}
{---------------------------------------------------------------------------
-----------------------}
function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string;
Quality: Integer): Boolean;
begin
Result := True;
try
if ForceDirectories(FilePath) then
begin
with TJPegImage.Create do
begin
try
Assign(Bitmap);
CompressionQuality := 70;
SaveToFile(FilePath + FileName);
finally
Free;
end; {try}
end; {with}
end; {if}
except
raise;
Result := False;
end; {try}
end; {SaveJPEGPictureFile}
procedure ResizeImage(FileName: string; MaxWidth: Integer);
var
OldBitmap: TBitmap;
NewBitmap: TBitmap;
aWidth: Integer;
begin
OldBitmap := TBitmap.Create;
try
if LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName),
ExtractFileName(FileName)) then
begin
aWidth := OldBitmap.Width;
if (OldBitmap.Width > MaxWidth) then
begin
aWidth := MaxWidth;
NewBitmap := TBitmap.Create;
try
NewBitmap.Width := MaxWidth;
NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height,
OldBitmap.Width);
SmoothResize(OldBitmap, NewBitmap);
RenameFile(FileName, ChangeFileExt(FileName, '.$$$'));
if SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName),
ExtractFileName(FileName), 75) then
DeleteFile(ChangeFileExt(FileName, '.$$$'))
else
RenameFile(ChangeFileExt(FileName, '.$$$'), FileName);
finally
NewBitmap.Free;
end; {try}
end; {if}
end; {if}
finally
OldBitmap.Free;
end; {try}
end;
// Para usar cuidado, ele apaga a imagem de origem
procedure TForm1.Button1Click(Sender: TObject);
begin
ResizeImage('C:\tolardo1.jpg', 99);
end;
--------------------
procedure ResizeBitmap(imgo, imgd: TBitmap; nw, nh: Integer);
var
xini, xfi, yini, yfi, saltx, salty: single;
x, y, px, py, tpix: integer;
PixelColor: TColor;
r, g, b: longint;
function MyRound(const X: Double): Integer;
begin
Result := Trunc(x);
if Frac(x) >= 0.5 then
if x >= 0 then Result := Result + 1
else
Result := Result - 1;
// Result := Trunc(X + (-2 * Ord(X < 0) + 1) * 0.5);
end;
begin
// Set target size
imgd.Width := nw;
imgd.Height := nh;
// Calcs width & height of every area of pixels of the source bitmap
saltx := imgo.Width / nw;
salty := imgo.Height / nh;
yfi := 0;
for y := 0 to nh - 1 do
begin
// Set the initial and final Y coordinate of a pixel area
yini := yfi;
yfi := yini + salty;
if yfi >= imgo.Height then yfi := imgo.Height - 1;
xfi := 0;
for x := 0 to nw - 1 do
begin
// Set the inital and final X coordinate of a pixel area
xini := xfi;
xfi := xini + saltx;
if xfi >= imgo.Width then xfi := imgo.Width - 1;
// This loop calcs del average result color of a pixel area
// of the imaginary grid
r := 0;
g := 0;
b := 0;
tpix := 0;
for py := MyRound(yini) to MyRound(yfi - 1) do
begin
for px := MyRound(xini) to MyRound(xfi) do
begin
Inc(tpix);
PixelColor := ColorToRGB(imgo.Canvas.Pixels[px, py]);
r := r + GetRValue(PixelColor);
g := g + GetGValue(PixelColor);
b := b + GetBValue(PixelColor);
end;
end;
// Draws the result pixel
imgd.Canvas.Pixels[x, y] :=
rgb(MyRound(r / tpix),
MyRound(g / tpix),
MyRound(b / tpix)
);
end;
end;
end;
[]s
Walter Alves Chagas Junior
Projeto e desenvolvimento
Telemont Engenharia de telecomunicações
[EMAIL PROTECTED]
Fone: (31) 3389-8215 Fax: (31) 3389-8200
> -----Mensagem original-----
> De: Uillian Fernandes [mailto:[EMAIL PROTECTED]
> Enviada em: quinta-feira, 17 de fevereiro de 2005 12:51
> Para: delphi-br@yahoogrupos.com.br
> Assunto: [delphi-br] TRABALHANDO COM IMAGENS !!!!!!!!!!!!!!!!!!!!!!!!!
>
>
>
> Pessoal, além de trabalhar com Delphi eu tb trabalho com PHP.
>
> Em PHP eu tenho uma rotina que através de uma imagem obtido
> do banco(campo blob) eu consigo reformatá-la e diminur
> bastante o tamanho dela, ou seja, a imagem é gravado no banco
> com 200k, eu consigo formatá-la e chegar a 18 ou 20k.
>
> Alguém conhece alguma rotina em Delphi que faça o mesmo?????
>
> Atenciosamente
> ----- Original Message -----
> From: Rodrigo Izquierdo da Motta
> To: delphi-br@yahoogrupos.com.br
> Sent: Thursday, February 17, 2005 2:11 PM
> Subject: Re: [delphi-br] F12 no Kylix 2
>
>
> Ola Bruno!!!
>
> Sobre o teste do teclado, sim eu jah testei, ele
> funciona normalmente, realmente so no Kylix 2 que da
> isso, mas eu venho notando, parece que o Kylix no
> Mandrake 10, tem um Bugs estranhos mesmo, ele apezar
> de mostrar foco em uma janela, na verdade o foco esta
> em outra, e acredito que por isso que o F12 naum
> funcione sempre, pois o foco naum esta onde eu penso
> que esta, e outra bug bem chato eh o ShowModal, ele as
> vezes mostra o ShowModal de um View Form por exemplo,
> atras de outras janelas, e vc fica ali, que nem um
> palhaco tentando usar o sistema, ate que vc percebe
> que tem um Modal atras travando tudo, enfim eh muito
> estranho.
>
> Mas obrigado pela tentativa de ajuda cara, vlw
> mesmo!!!
>
> Um Abraco a Todos!!!!
>
>
> (*=================================================*)
>
> --- Bruno <[EMAIL PROTECTED]> escreveu:
> >
> > Já verificou em outros aplicativos se não é seu
> > teclado?
> >
> > Em Mon, 31 Jan 2005 11:15:34 -0300 (ART), Rodrigo
> > Izquierdo da Motta
> > <[EMAIL PROTECTED]> escreveu:
> >
> > > Ola Lista!!!
> > >
> > > Eu uso o Kylix 2, e estou com um problema basico,
> > mas
> > > que encomoda com o passar do tempo, eh o sequinte,
> > > quando estou no formulario e quero passar para o
> > > codigo fonte, eu uso muito o F12, mas no Kylix,
> > ele
> > > naum funciona sempre, as vezes tenho que usar o
> > mouse,
> > > e clicar no botao que faz isso, ai do codigo pro
> > > formulario ele volta, ai se eu naum usar o botao
> > pra
> > > voltar pro codigo, se eu usar o mouse por exemplo
> > e
> > > clicar no codigo o F12 denovo, naum funciona mais.
> > > Naum sei se deu pra entender muito bem, pois eh
> > > confuso de explicar. Mas Basicamente o F12 naum
> > > funciona. Sera que alguem jah passou por isso e
> > sabe
> > > resolver?
> > >
> > > Obrigado!!!
> > >
> > >
> > >
> > > =====
> > > Rodrigo Izquierdo da Motta.
> > >
> > >
> > >
> > >
> > >
> > >
> > >
> > >
> >
> _______________________________________________________
> > > Yahoo! Acesso Grátis - Instale o discador do
> > Yahoo! agora.
> > > http://br.acesso.yahoo.com/
> > > - Internet rápida e grátis
> > >
> > >
> >
> >
> >
> > --
> > Bruno Araujo
> >
> >
> >
> >
> > --
> > <<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA
> > MENSAGEM >>>>>
> >
> > Para ver as mensagens antigas, acesse:
> > http://br.groups.yahoo.com/group/delphi-br/messages
> >
> > Para falar com o moderador, envie um e-mail para:
> > [EMAIL PROTECTED] ou
> > [EMAIL PROTECTED]
> >
> > Links do Yahoo! Grupos
> >
> >
> >
> > http://br.yahoo.com/info/utos.html
> >
> >
> >
> >
> >
> >
>
> =====
> Rodrigo Izquierdo da Motta.
>
>
>
>
>
>
>
> _______________________________________________________
> Yahoo! Acesso Grátis - Instale o discador do Yahoo! agora.
> http://br.acesso.yahoo.com/ - Internet rápida e grátis
>
>
> --
> <<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA MENSAGEM >>>>>
>
> Para ver as mensagens antigas, acesse:
> http://br.groups.yahoo.com/group/delphi-br/messages
>
> Para falar com o moderador, envie um e-mail para:
> [EMAIL PROTECTED] ou [EMAIL PROTECTED]
>
>
>
> Yahoo! Grupos, um serviço oferecido por:
>
> São Paulo Rio de Janeiro Curitiba Porto
> Alegre Belo Horizonte Brasília
>
>
>
>
> --------------------------------------------------------------
> ----------------
> Links do Yahoo! Grupos
>
> a.. Para visitar o site do seu grupo na web, acesse:
> http://br.groups.yahoo.com/group/delphi-br/
>
> b.. Para sair deste grupo, envie um e-mail para:
> [EMAIL PROTECTED]
>
> c.. O uso que você faz do Yahoo! Grupos está sujeito aos
> Termos do Serviço do Yahoo!.
>
>
>
>
> [As partes desta mensagem que não continham texto foram removidas]
>
>
>
> --
> <<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA MENSAGEM >>>>>
>
> Para ver as mensagens antigas, acesse:
> http://br.groups.yahoo.com/group/delphi-br/messages
>
> Para falar com o moderador, envie um e-mail para:
> [EMAIL PROTECTED] ou [EMAIL PROTECTED]
>
> Links do Yahoo! Grupos
>
>
>
>
>
>
>
>
[As partes desta mensagem que não continham texto foram removidas]
--
<<<<< FAVOR REMOVER ESTA PARTE AO RESPONDER ESTA MENSAGEM >>>>>
Para ver as mensagens antigas, acesse:
http://br.groups.yahoo.com/group/delphi-br/messages
Para falar com o moderador, envie um e-mail para:
[EMAIL PROTECTED] ou [EMAIL PROTECTED]
Links do Yahoo! Grupos
<*> Para visitar o site do seu grupo na web, acesse:
http://br.groups.yahoo.com/group/delphi-br/
<*> Para sair deste grupo, envie um e-mail para:
[EMAIL PROTECTED]
<*> O uso que você faz do Yahoo! Grupos está sujeito aos:
http://br.yahoo.com/info/utos.html
