大虾请进-----------为什么这个截取图片的代码有问题?

[cowbo2]

走过路过的兄弟帮看下,折腾了几天了..
这个功能要实现的,就是把一个BMP图片周边的空白,全部截取掉,只保留有图像的部份,
但为什么运行后,还是有空白?

怎么改?谢了.

unit FixImg;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, ExtDlgs, Buttons, StdCtrls, ExtCtrls;

type
    TFixImgForm = class(TForm)
        edt1: TEdit;
        Label1: TLabel;
        Button1: TButton;
        BitBtn1: TBitBtn;
        OpenPictureDialog1: TOpenPictureDialog;
    Image1: TImage;
        procedure Button1Click(Sender: TObject);
        function CutImgRang(StretchImage:TBitmap): TRect;
    procedure BitBtn1Click(Sender: TObject);
    private
    { Private declarations }
    public
    { Public declarations }
    end;

var
    FixImgForm: TFixImgForm;

implementation

{$R *.dfm}

//截掉图片里周边的空白区域
function TFixImgForm.CutImgRang(StretchImage:TBitmap): TRect;
var // 得到图片上的最左、最右、最上、最下的点
    i, j: integer;
    label FindMostRight, FindMostTop, FindMostBottom, FindInMiddle;
begin
    //FindMostLeft: // 获得最左边的点
    for i := 1 to StretchImage.Width - 1 do
        for j := 1 to StretchImage.Height - 1 do
            if StretchImage.Canvas.Pixels[i, j] <> clWhite then
            begin
                Result.Left := i;
                goto FindMostRight;
            end;
            
    FindMostRight: // 获得最右边的点
    for i := StretchImage.Width - 1 downto 1 do
        for j := 1 to StretchImage.Height - 1 do
            if StretchImage.Canvas.Pixels[i, j] <> clWhite then
            begin
                Result.Right := i;
                goto FindMostTop;
            end;
            
    FindMostTop: // 获得最上面的点
    for j := 1 to StretchImage.Height - 1 do
        for i := 1 to StretchImage.Width - 1 do
            if StretchImage.Canvas.Pixels[i, j] <> clWhite then
            begin
                Result.Top := j;
                goto FindMostBottom;
            end;
            
    FindMostBottom: // 获得最下面的点
    for j := StretchImage.Height - 1 downto 1 do
        for i := 1 to StretchImage.Width - 1 do
            if StretchImage.Canvas.Pixels[i, j] <> clWhite then
            begin
                Result.Bottom := j;
                goto FindInMiddle;
            end;
            
    FindInMiddle:
    i := Result.Right - Result.Left; // 得到区域宽度
    j := Result.Bottom - Result.Top; // 得到区域高度
    i := i mod 8;
    i := i div 2;
    if i > 0 then // 将边缘对称于矩形的左右部分
    begin
        Dec(Result.Left, i);
        Inc(Result.Right, i);
    end;
    j := j mod 8;
    j := j div 2;
    if j > 0 then // 将边缘对称于矩形的上下部分
    begin
        Dec(Result.Top, i);
        Inc(Result.Bottom, j);
    end;
  // 对左右部分过小的图片进行加宽处理
    i := Result.Right - Result.Left;
    if i < 80 then // 细长的黑色的字最小宽为80
    begin
        i := (80 - i) div 2;
        Dec(Result.Left, i);
        Inc(Result.Right, i);
    end;
end;

//选择BMP图片
procedure TFixImgForm.BitBtn1Click(Sender: TObject);
var
    recttmp,SourceRect:TRect;
begin


     recttmp:=CutImgRang(Image1.Picture.Bitmap);//取得要截取的区域

     FixImgForm.Repaint; 
     FixImgForm.Canvas.CopyRect(recttmp,Image1.Canvas, recttmp);//复制截取的区域
end;

procedure TFixImgForm.Button1Click(Sender: TObject);
begin
    if OpenPictureDialog1.Execute then
    begin
        edt1.Text := OpenPictureDialog1.FileName;
        Image1.Picture.LoadFromFile(edt1.Text);
    end;
end;

end.

[sololie]

没看到你有指定copymode,如果不指定，默认是cmsrccopy fiximgform.copymode:=cmsrcand; FixImgForm.Canvas.CopyRect(recttmp,Image1.Canvas, recttmp);

[sololie]

写漏canvas了 fiximgform.canvas.copymode:=cmsrcand;

[sololie]

这水平也叫大师，高级黑啊 俺也没看你那一大段代码，直接复制来测试没问题啊，贴张你用的测试图来瞅瞅是啥样

[cowbo2]

引用 4 楼 sololie 的回复:

这水平也叫大师，高级黑啊 俺也没看你那一大段代码，直接复制来测试没问题啊，贴张你用的测试图来瞅瞅是啥样

就用你的头像,呵呵 把图像转成BMP后执行一下看下.

[sololie]

有些图片你看着像是白色的地方，其实不是纯白色，掺杂着一些其他很像白色的颜色
你可以在预览窗口看看就知道了

[sololie]

你可以先把图片二值画成黑白色，然后再获取这个recttmp,再用未二值画的原图copyrect上去

[sololie]

最下面的是二值化后的图，中间是原图，第一个是处理后的图
看原图中黑线画出的界限之外的白色被去掉了

[cowbo2]

引用 2 楼 sololie 的回复:

写漏canvas了 fiximgform.canvas.copymode:=cmsrcand;

大师,操作是一直可以,但是截出来的图片,怎么就达不到去掉边上的空白的效果呢?

[sololie]

我的代码都是抄你上面的，都说了先做个二值化就行了, 简单的二值化就两行 xxxbmp.pixelformat:=pfdevice; xxxbmp.pixelformat:=pf1bit;

[sololie]

function TForm1.CutImgRang({参数名改了}srcImg: TBitmap): TRect;
var 
  i, j: integer;
  StretchImage: TBitmap;{////////////////}
label
  FindMostRight, FindMostTop, FindMostBottom, FindInMiddle;
begin
  ////////////////////////////////
  StretchImage := TBitmap.Create;
  StretchImage.Assign(srcImg);
  StretchImage.PixelFormat := pfDevice;
  StretchImage.PixelFormat := pf1bit;
  ////////////////////////////////

  for i := 1 to StretchImage.Width - 1 do
    for j := 1 to StretchImage.Height - 1 do
      if StretchImage.Canvas.Pixels[i, j] <> clWhite then
      begin
        Result.Left := i;
        goto FindMostRight;
      end;

  FindMostRight: 
  for i := StretchImage.Width - 1 downto 1 do
    for j := 1 to StretchImage.Height - 1 do
      if StretchImage.Canvas.Pixels[i, j] <> clWhite then
      begin
        Result.Right := i;
        goto FindMostTop;
      end;

  FindMostTop: 
  for j := 1 to StretchImage.Height - 1 do
    for i := 1 to StretchImage.Width - 1 do
      if StretchImage.Canvas.Pixels[i, j] <> clWhite then
      begin
        Result.Top := j;
        goto FindMostBottom;
      end;

  FindMostBottom: 
  for j := StretchImage.Height - 1 downto 1 do
    for i := 1 to StretchImage.Width - 1 do
      if StretchImage.Canvas.Pixels[i, j] <> clWhite then
      begin
        Result.Bottom := j;
        goto FindInMiddle;
      end;

  FindInMiddle:
  i := Result.Right - Result.Left; 
  j := Result.Bottom - Result.Top;
  i := i mod 8;
  i := i div 2;
  if i > 0 then 
  begin
    Dec(Result.Left, i);
    Inc(Result.Right, i);
  end;
  j := j mod 8;
  j := j div 2;
  if j > 0 then 
  begin
    Dec(Result.Top, i);
    Inc(Result.Bottom, j);
  end;

  i := Result.Right - Result.Left;
  if i < 80 then 
  begin
    i := (80 - i) div 2;
    Dec(Result.Left, i);
    Inc(Result.Right, i);
  end;
  ////////////////////////////////
  StretchImage.Free;
  ////////////////////////////////
end;

procedure TForm1.btn1Click(Sender: TObject);
var
  recttmp: TRect;
  bmp: TBitmap;
begin
  if dlgOpen1.Execute then
  begin
    img1.Picture.LoadFromFile(dlgOpen1.FileName);
  end;

  recttmp := CutImgRang(img1.Picture.Bitmap); //取得要截取的区域
  Repaint;

  bmp := TBitmap.Create;
  bmp.Width := recttmp.Right - recttmp.Left;
  bmp.Height := recttmp.Bottom - recttmp.Top;
  bmp.Canvas.CopyRect(Rect(0, 0, bmp.Width, bmp.Height), img1.Canvas, recttmp);
  Canvas.Draw(0, 0, bmp); // 在窗体上预览
  bmp.SaveToFile('c:\ttttttttt.bmp'); // 保存裁剪后的图片
  bmp.Free;
end;

[cowbo2]

引用 8 楼 sololie 的回复:

最下面的是二值化后的图，中间是原图，第一个是处理后的图 看原图中黑线画出的界限之外的白色被去掉了

你的源码可以发出来看一下吗?为什么我的达不到那样的效果...

[jackout]

厉害.......

[youyidianmimang]

引用 11 楼 sololie 的回复:

function TForm1.CutImgRang({参数名改了}srcImg: TBitmap): TRect;
var 
  i, j: integer;
  StretchImage: TBitm....
        goto FindMostBottom;
      end;

  FindMostBottom: 
  for j := StretchImage.Height - 1 downto 1 do
    for i := 1 to StretchImage.Width - 1 do
      if StretchImage.Canvas.Pixels[i, j] <> clWhite then
      begin
end;

居然还有在用 goto 哈~~~; 不过大部分人都是在剔除这个用法...好像以前vb里有的.

[Andy-88]

膜拜 大神