ビットマップ画像をトリミングするには？ (ID:8396)

名前

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

本文

トリミング＝余白を取り除いた部分、ということでしょうか。
こんな感じでどうですか。
最適化していません。エラー処理もしていません。
動作確認済みです。

type
  TColor24=packed record
    R,G,B: BYTE;
  end;
  PColor24Array=^TColor24Array;
  TColor24Array=array[0..0] of TColor24;

function TrimBitmap(AColor: TColor; Source, Dest: TBitmap): Boolean;
var
  C: TColor24; // 探す色
  x, y: Integer;//ループ変数
  mx1, mx2, my1, my2: Integer; // トリムの最小値
  lx1, lx2: Integer; // １ラインあたりのトリムの最小
  SScan: PCOlor24Array;
  IsLeftFound, IsTopFound: Boolean; // 内側範囲を見つけたらTrue
  SR,DR: TRect;

function CheckColor(A,B: TColor24): Boolean;
  begin
    //色のチェック。必要なら、１色でなく平均値以下とかに変更。
    if  (SScan[x].R = C.R)
    and (SScan[x].G = C.G)
    and (SScan[x].B = C.B) then
      Result := False // 余白
    else
      Result := True; // 余白ではない
  end;
begin
  mx1 := Source.Width - 1;
  mx2 := 0;
  my1 := Source.Height - 1;
  my2 := 0;
  C.R :=  AColor         and 255;
  C.G := (AColor shr  8) and 255;
  C.B := (AColor shr 16) and 255;
  Source.PixelFormat := pf24bit;
  IsTopFound := False;
  for y := 0 to Source.Height - 1 do
  begin
    SScan := Source.ScanLine[y];
    IsLeftFound := False;
    lx1 := 0;
    lx2 := 0;
    for x := 0 to Source.Width - 1 do
    begin
      //左からの値
      if CheckColor(C, SScan[x]) then
      begin
        // 余白でない場所を発見
        if not IsLeftFound then
        begin
          IsLeftFound := True;
          lx1 := x;
        end;
        //右側の場合、最後に余白でない場所を探せばよいのでここでチェック
        lx2 := x;
      end
      else
      begin
        //余白
        if not IsLeftFound then lx1 := x;
      end;
    end;
    //前に探した余白の位置より小さいなら今の位置を余白位置とする
    if mx1 > lx1 then mx1 := lx1;

//前に探した余白の位置より大きいなら今の位置を余白位置とする
    if mx2 < lx2 then mx2 := lx2;

if lx1 < lx2 then
    begin
      //余白ではない場所を発見
      if not IsTopFound then
      begin
        IsTopFound := True;
        my1 := y;
      end;
      //下側の場合、最後に余白でない場所を探せばよいのでここでチェック
      my2 := y;
    end
    else
    begin
      //余白
      if not IsTopFound then my1 := y; 
    end;
  end;

//すべて余白ならコピーしないで戻る
  if (mx1 > mx2) or (my1 > my2) then
  begin
    Result := False;
    Exit;
  end;

//Destにソースの範囲をコピー
  Dest.Width  := mx2 - mx1 + 1;
  Dest.Height := my2 - my1 + 1;
  Dest.PixelFormat := pf24bit;

SR.Left := mx1;
  SR.Top := my1;
  SR.Right := mx2 + 1;
  SR.Bottom := my2 + 1;

DR.Left := 0;
  DR.Top := 0;
  DR.Right := mx2 - mx1 + 1;
  DR.Bottom := my2 - my1 + 1;

Dest.Canvas.CopyRect(DR, Source.Canvas, SR);

Result := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S,D: TBitmap;
begin
  S := TBitmap.Create;
  D := TBitmap.Create;
  try
    S.LoadFromFile(Edit1.Text);
    if TrimBitmap(RGB(255,255,255), S, D) then
    begin
      D.SaveToFile(Edit2.Text);
      ShowMessage('Trim完了');
    end
    else
    begin
      ShowMessage('Trimされませんでした');
    end;
  finally
    D.Free;
    S.Free;
  end;
end;

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

戻る