StretchBltのやりかた (ID：29663)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

HALFTONEを使ったFunc_Aの縮小方法でもかなりイケルけど、
髪の毛や眼など、線や細かい部分では、Func_Bの方がイイね。

type
  PAryRGBTr = ^TAryRGBTr;
  TAryRGBTr = array[0..$1FFF] of TRGBTriple;
const
  RATE = 0.3000;        // 縮小率
  PATH = 'C:\My Documents\My Pictures\';

// HALFTONEを指定してStretchBlt関数
procedure TForm1.Func_A(Jpg: TJPEGImage);
var
  w, h, w1, h1: Integer;
begin
  Image1.Picture.Bitmap.Assign(Jpg);
  w := Image1.Picture.Width;
  h := Image1.Picture.Height;
  w1 := Round(w * RATE);
  h1 := Round(h * RATE);
  Image2.Picture.Bitmap.Width := w1;
  Image2.Picture.Bitmap.Height := h1;
  SetStretchBltMode(Image2.Canvas.Handle, HALFTONE);
  StretchBlt(Image2.Canvas.Handle, 0, 0, w1, h1, Image1.Canvas.Handle, 0, 0, w, h, SRCCOPY);
  Image2.Invalidate;
end;

// 独自のリサイズ関数
procedure TForm1.Func_B(Jpg: TJPEGImage);
 //------------------------------------------
 procedure ResizeBmp(SrcBmp, DstBmp: TBitmap);
 var
  x, y: Integer;
  xP, yP, xD, yD: Integer;
  w1, w2, w3, w4: Integer;
  zz, nz, iz, tt: Integer;
  DstGaps: Integer;
  SrcLine1, SrcLine2, DstLine: PAryRGBTr;
 begin
  SrcBmp.PixelFormat := pf24Bit;
  DstBmp.PixelFormat := pf24Bit;
  if (SrcBmp.Width = DstBmp.Width) and (SrcBmp.Height = DstBmp.Height) then begin
   DstBmp.Assign(SrcBmp);
  end else begin
   DstLine := DstBmp.ScanLine[0];
   DstGaps := PChar(DstBmp.ScanLine[1]) - PChar(DstLine);
   xD := MulDiv(Pred(SrcBmp.Width), $10000, DstBmp.Width);
   yD := MulDiv(Pred(SrcBmp.Height), $10000, DstBmp.Height);
   yP := 0;
   for y := 0 to Pred(DstBmp.Height) do begin
    xP := 0;
    SrcLine1 := SrcBmp.ScanLine[yP shr 16];
    if (yP shr 16 < Pred(SrcBmp.Height)) then begin
     SrcLine2 := SrcBmp.ScanLine[Succ(yP shr 16)]
    end else begin
     SrcLine2 := SrcBmp.ScanLine[yP shr 16];
    end;
    nz := Succ(yP and $FFFF);
    iz := Succ((not yP) and $FFFF);
    for x := 0 to Pred(DstBmp.Width) do begin
     tt := xP shr 16;
     zz := xP and $FFFF;
     w2 := MulDiv(zz, iz, $10000);
     w1 := iz - w2;
     w4 := MulDiv(zz, nz, $10000);
     w3 := nz - w4;
     DstLine[x].rgbtRed := (SrcLine1[tt].rgbtRed * w1 + SrcLine1[tt + 1].rgbtRed * w2
       + SrcLine2[tt].rgbtRed * w3 + SrcLine2[tt + 1].rgbtRed * w4) shr 16;
     DstLine[x].rgbtGreen := (SrcLine1[tt].rgbtGreen * w1 + SrcLine1[tt + 1].rgbtGreen * w2
       + SrcLine2[tt].rgbtGreen * w3 + SrcLine2[tt + 1].rgbtGreen * w4) shr 16;
     DstLine[x].rgbtBlue := (SrcLine1[tt].rgbtBlue * w1 + SrcLine1[tt + 1].rgbtBlue * w2
       + SrcLine2[tt].rgbtBlue * w3 + SrcLine2[tt + 1].rgbtBlue * w4) shr 16;
     Inc(xP, xD);
    end;
    Inc(yP, yD);
    DstLine := PAryRGBTr(PChar(DstLine) + DstGaps);
   end;
  end;
 end;
 //------------------------------------------
var
  w, h: Integer;
begin
  Image1.Picture.Bitmap.Assign(Jpg);
  w := Image1.Picture.Width;
  h := Image1.Picture.Height;
  Image2.Picture.Bitmap.Width := Round(w * RATE);
  Image2.Picture.Bitmap.Height := Round(h * RATE);
  ResizeBmp(Image1.Picture.Bitmap, Image2.Picture.Bitmap);
  Image2.Invalidate;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Jpg: TJPEGImage;
  sr: TSearchRec;
begin
 Jpg := TJPEGImage.Create;
 try
  if FindFirst(PATH +'*.jpg', faArchive, sr) <> 0 then exit;
  repeat
   Caption := sr.Name;
   Jpg.LoadFromFile(PATH + sr.Name);
   Func_A(Jpg);
   Application.ProcessMessages; Sleep(1000);
   Func_B(Jpg);
   Jpg.Assign(Image2.Picture.Bitmap);
// Jpg.SaveToFile('T_'+ sr.Name);
   Application.ProcessMessages; Sleep(1000);
   if GetKeyState(VK_ESCAPE) < 0 then break;
  until FindNext(sr) <> 0;
  FindClose(sr);
 finally
  Jpg.Free;
 end;
end;

←解決時は質問者本人がここをチェックしてください。

戻る