Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Качественно уменьшить изображение

01.01.2007

В Delphi изменять размеры изображения очень просто, используя CopyRect:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1
.Canvas.Font.Size := 24;
  Form1
.Canvas.TextOut(0, 0, 'Text');
  Form1
.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas,
 
Bounds(0, 0, 100, 40));
end;

Но этот способ не очень хорош для уменьшения не маленьких картинок – мелкие детали сливаются. Для частичного устранения этого недостатка при уменьшении изображения в четыре раза я беру средний цвет в каждом квадратике 4X4. К чему это приводит, посмотрите сами.

procedure TForm1.Button1Click(Sender: TObject);
var
  x
, y: integer;
  i
, j: integer;
  r
, g, b: integer;
begin
  Form1
.Canvas.Font.Size := 24;
  Form1
.Canvas.TextOut(0, 0, 'Text');
 
for y := 0 to 10 do
 
begin
   
for x := 0 to 25 do
   
begin
      r
:= 0;
     
for i := 0 to 3 do
       
for j := 0 to 3 do
          r
:= r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      r
:= round(r / 16);
      g
:= 0;
     
for i := 0 to 3 do
       
for j := 0 to 3 do
          g
:= g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      g
:= round(g / 16);
      b
:= 0;
     
for i := 0 to 3 do
       
for j := 0 to 3 do
          b
:= b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      b
:= round(b / 16);
      Form1
.Canvas.Pixels[x,y+50] := RGB(r, g, b)
   
end;
   
Application.ProcessMessages;
 
end;
end;

unit ProjetoX_Screen;
 
interface
 
uses
 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 
ExtCtrls, StdCtrls, DBCtrls;
 
type
 
TFormScreen = class(TForm)
   
ImgFundo: TImage;
    procedure
FormCreate(Sender: TObject);
 
public
   
MyRegion : HRGN;
   
function BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;
 
end;
 
var
 
FormScreen: TFormScreen;
 
implementation
 
{$R *.DFM}
function TFormScreen.BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;
 
const
  ALLOC_UNIT
= 100;
 
var
 
MemDC, DC: HDC;
 
BitmapInfo: TBitmapInfo;
  hbm32
, holdBmp, holdMemBmp: HBitmap;
  pbits32
: Pointer;
  bm32
: BITMAP;
  maxRects
: DWORD;
  hData
: HGLOBAL;
  pData
: PRgnData;
  b
, CR, CG, CB : Byte;
  p32
: pByte;
  x
, x0, y: integer;
  p
: pLongInt;
  pr
: PRect;
  h
: HRGN;
 
begin
 
Result := 0;
 
if hBmp <> nil then
 
begin
   
MemDC := CreateCompatibleDC(0);
   
if MemDC <> 0 then
   
begin
     
with BitmapInfo.bmiHeader do
     
begin
        biSize          
:= sizeof(TBitmapInfoHeader);
        biWidth        
:= hBmp.Width;
        biHeight        
:= hBmp.Height;
        biPlanes        
:= 1;
        biBitCount      
:= 32;
        biCompression  
:= BI_RGB;
        biSizeImage    
:= 0;
        biXPelsPerMeter
:= 0;
        biYPelsPerMeter
:= 0;
        biClrUsed      
:= 0;
        biClrImportant  
:= 0;
     
end;
      hbm32
:= CreateDIBSection(MemDC, BitmapInfo, DIB_RGB_COLORS, pbits32,0, 0);
     
if hbm32 <> 0 then
     
begin
        holdMemBmp
:= SelectObject(MemDC, hbm32);
       
GetObject(hbm32, SizeOf(bm32), @bm32);
       
while (bm32.bmWidthBytes mod 4) > 0 do
          inc
(bm32.bmWidthBytes);
        DC
:= CreateCompatibleDC(MemDC);
        holdBmp
:= SelectObject(DC, hBmp.Handle);
       
BitBlt(MemDC, 0, 0, hBmp.Width, hBmp.Height, DC, 0, 0, SRCCOPY);
        maxRects
:= ALLOC_UNIT;
        hData
:= GlobalAlloc(GMEM_MOVEABLE, sizeof(TRgnDataHeader) +
           
SizeOf(TRect) * maxRects);
        pData
:= GlobalLock(hData);
        pData
^.rdh.dwSize := SizeOf(TRgnDataHeader);
        pData
^.rdh.iType := RDH_RECTANGLES;
        pData
^.rdh.nCount := 0;
        pData
^.rdh.nRgnSize := 0;
       
SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);
        CR
:= GetRValue(ColorToRGB(TransColor));
        CG
:= GetGValue(ColorToRGB(TransColor));
        CB
:= GetBValue(ColorToRGB(TransColor));
        p32
:= bm32.bmBits;
        inc
(PChar(p32), (bm32.bmHeight - 1) * bm32.bmWidthBytes);
       
for y := 0 to hBmp.Height-1 do
       
begin
          x
:= -1;
         
while x+1 < hBmp.Width do
         
begin
            inc
(x);
            x0
:= x;
            p
:= PLongInt(p32);
            inc
(PChar(p), x * SizeOf(LongInt));
           
while x < hBmp.Width do
           
begin
              b
:= GetBValue(p^);
             
if (b = CR) then
             
begin
                b
:= GetGValue(p^);
               
if (b = CG) then
               
begin
                  b
:= GetRValue(p^);
                 
if (b = CB) then
                   
break;
               
end;
             
end;
              inc
(PChar(p), SizeOf(LongInt));
              inc
(x);
           
end;
           
if x > x0 then
           
begin
             
if pData^.rdh.nCount >= maxRects then
             
begin
               
GlobalUnlock(hData);
                inc
(maxRects, ALLOC_UNIT);
                hData
:= GlobalReAlloc(hData, SizeOf(TRgnDataHeader) +
                   
SizeOf(TRect) * maxRects, GMEM_MOVEABLE);
                pData
:= GlobalLock(hData);
               
Assert(pData <> NIL);
             
end;
              pr
:= @pData^.Buffer[pData^.rdh.nCount * SizeOf(TRect)];
             
SetRect(pr^, x0, y, x, y+1);
             
if x0 < pData^.rdh.rcBound.Left then
                pData
^.rdh.rcBound.Left := x0;
             
if y < pData^.rdh.rcBound.Top then
                pData
^.rdh.rcBound.Top := y;
             
if x > pData^.rdh.rcBound.Right then
                pData
^.rdh.rcBound.Left := x;
             
if y+1 > pData^.rdh.rcBound.Bottom then
                pData
^.rdh.rcBound.Bottom := y+1;
              inc
(pData^.rdh.nCount);
             
if pData^.rdh.nCount = 2000 then
             
begin
                h
:= ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +
                   
(SizeOf(TRect) * maxRects), pData^);
               
Assert(h <> 0);
               
if Result <> 0 then
               
begin
                 
CombineRgn(Result, Result, h, RGN_OR);
                 
DeleteObject(h);
               
end else
                 
Result := h;
                pData
^.rdh.nCount := 0;
               
SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);
             
end;
           
end;
         
end;
         
Dec(PChar(p32), bm32.bmWidthBytes);
       
end;
        h
:= ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +
           
(SizeOf(TRect) * maxRects), pData^);
       
Assert(h <> 0);
       
if Result <> 0 then
       
begin
         
CombineRgn(Result, Result, h, RGN_OR);
         
DeleteObject(h);
       
end else
         
Result := h;
       
GlobalFree(hData);
       
SelectObject(DC, holdBmp);
       
DeleteDC(DC);
       
DeleteObject(SelectObject(MemDC, holdMemBmp));
     
end;
   
end;
   
DeleteDC(MemDC);
 
end;
end;
 
procedure
TFormScreen.FormCreate(Sender: TObject);
begin
       
MyRegion := BitmapToRegion(imgFundo.Picture.Bitmap,imgFundo.Canvas.Pixels[0,0]);
       
SetWindowRgn(Handle,MyRegion,True);
end;
 
 
 
 
 
procedure
TFormXXXXXX.FormCreate(Sender: TObject);
begin
       
FormScreen.MyRegion := FormScreen.BitmapToRegion(imgFundo.Picture.Bitmap,
          imgFundo
.Canvas.Pixels[0,0]);
       
SetWindowRgn(Handle,FormScreen.MyRegion,True);
end;

Взято с https://delphiworld.narod.ru

procedure ShrinkPic(Big:TBitmap;Small:TBitmap;xscale:integer=0;yscale:integer=0);
//Из уже созданной картинки Big заполняет уже созданную картинку Small
var
x
, y: integer;
i
, j: integer;
r
, g, b: integer;
begin
//Если указан фактор сжатия по ширине, то устанавливаем правильный размер, иначе вычисляем фактор
if xscale=0
then xscale:=Big.Width div Small.Width
else Small.Width:=Big.Width div xscale;
//Если указан фактор сжатия по высоте, то устанавливаем правильный размер, иначе вычисляем фактор
if yscale=0
then yscale:=Big.Height div Small.Height
else Small.Height:=Big.Height div yscale;
for y := 0 to Small.Height-1 do
for x := 0 to Small.Width-1 do
begin
r
:= 0;
g
:= 0;
b
:= 0;
for i := 0 to xscale-1 do
for j := 0 to yscale-1 do
begin
r
:= r + GetRValue(Big.Canvas.Pixels[xscale*x+i, yscale*y+j]);
g
:= g + GetGValue(Big.Canvas.Pixels[xscale*x+i, yscale*y+j]);
b
:= b + GetBValue(Big.Canvas.Pixels[xscale*x+i, yscale*y+j]);
end;//for, for
r
:= round(r/xscale/yscale);
g
:= round(g/xscale/yscale);
b
:= round(b/xscale/yscale);
Small.Canvas.Pixels[x,y]:=RGB(r,g,b)
end;//for y, x
end;//ShrinkPic

Замечания.
1. В двух вложенных форах можно xscale-1 или yscale-1 заменить константой, в зависимости от области использования. Мой пример соптимизирован для соотношения 4:1.
2. Процедура медленная. Даже использование scanline'ов не спасает ситуацию кардинально, поэтому я не стал приводить более быстродействующий вариант, так как он более запутан. Для продвинутого преобразования я использую отдельную библиотеку.

Автор: December

Взято с Vingrad.ru https://forum.vingrad.ru