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

cowbo2 2014-01-15 12:09:27
走过路过的兄弟帮看下,折腾了几天了..
这个功能要实现的,就是把一个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.

...全文
236 14 点赞 打赏 收藏 举报
写回复
14 条回复
切换为时间正序
当前发帖距今超过3年,不再开放新的回复
发表回复
Andy-88 2014-01-21
膜拜 大神
  • 打赏
  • 举报
回复
youyidianmimang 2014-01-20
引用 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里有的.
  • 打赏
  • 举报
回复
jackout 2014-01-19
厉害.......
  • 打赏
  • 举报
回复
cowbo2 2014-01-17
引用 8 楼 sololie 的回复:
最下面的是二值化后的图,中间是原图,第一个是处理后的图 看原图中黑线画出的界限之外的白色被去掉了
你的源码可以发出来看一下吗?为什么我的达不到那样的效果...
  • 打赏
  • 举报
回复
sololie 2014-01-17

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;
  • 打赏
  • 举报
回复
sololie 2014-01-17
我的代码都是抄你上面的,都说了先做个二值化就行了, 简单的二值化就两行 xxxbmp.pixelformat:=pfdevice; xxxbmp.pixelformat:=pf1bit;
  • 打赏
  • 举报
回复
cowbo2 2014-01-16
引用 2 楼 sololie 的回复:
写漏canvas了 fiximgform.canvas.copymode:=cmsrcand;
大师,操作是一直可以,但是截出来的图片,怎么就达不到去掉边上的空白的效果呢?
  • 打赏
  • 举报
回复
sololie 2014-01-16
最下面的是二值化后的图,中间是原图,第一个是处理后的图
看原图中黑线画出的界限之外的白色被去掉了

  • 打赏
  • 举报
回复
sololie 2014-01-16
你可以先把图片二值画成黑白色,然后再获取这个recttmp,再用未二值画的原图copyrect上去
  • 打赏
  • 举报
回复
sololie 2014-01-16
有些图片你看着像是白色的地方,其实不是纯白色,掺杂着一些其他很像白色的颜色
你可以在预览窗口看看就知道了
  • 打赏
  • 举报
回复
cowbo2 2014-01-16
引用 4 楼 sololie 的回复:
这水平也叫大师,高级黑啊 俺也没看你那一大段代码,直接复制来测试没问题啊,贴张你用的测试图来瞅瞅是啥样
就用你的头像,呵呵 把图像转成BMP后执行一下看下.
  • 打赏
  • 举报
回复
sololie 2014-01-16
这水平也叫大师,高级黑啊 俺也没看你那一大段代码,直接复制来测试没问题啊,贴张你用的测试图来瞅瞅是啥样
  • 打赏
  • 举报
回复
sololie 2014-01-15
写漏canvas了 fiximgform.canvas.copymode:=cmsrcand;
  • 打赏
  • 举报
回复
sololie 2014-01-15
没看到你有指定copymode,如果不指定,默认是cmsrccopy fiximgform.copymode:=cmsrcand; FixImgForm.Canvas.CopyRect(recttmp,Image1.Canvas, recttmp);
  • 打赏
  • 举报
回复
相关推荐
发帖
Delphi
创建于2007-08-02

4928

社区成员

Delphi 开发及应用
申请成为版主
帖子事件
创建了帖子
2014-01-15 12:09
社区公告
暂无公告