如何实现裁剪框并剪切图像 ( 积分: 100 )

  • 主题发起人 主题发起人 wbamboo
  • 开始时间 开始时间
W

wbamboo

Unregistered / Unconfirmed
GUEST, unregistred user!
本人刚接触图像处理,现在想实现图像的裁剪功能,就是在图像上用鼠标拉出一个剪裁框,然后将剪裁框中图像存成一张jpg图片,图片大小不小于10k,不超过200k,不知如何实现?
望高人们指点!
 
这个是截屏的东西
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, RzTray, ImgList, TB2Item, TBSkinPlus, Menus, Clipbrd, Unit2;

const
MappingFileName = 'HookHandleFile';
WM_MOUSEHOOK = WM_USER + 1;

type
TForm1 = class(TForm)
RzTrayIcon1: TRzTrayIcon;
TBPopupMenu1: TTBPopupMenu;
TBSkin1: TTBSkin;
TBItem1: TTBItem;
TBImageList1: TTBImageList;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure TBItem1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
private
FScreenCanvas: TCanvas;
FBitmap: TBitmap;
FClipboard: TClipboard;
FEnable: Boolean;
FHFileMapping: Cardinal;
FHotKeyID1: Integer;
FHotKeyID2: Integer;
FPtStart: TPoint;
FPtEnd: TPoint;
FMouseDown: Boolean;
procedure WMHotKey(var Msg: TMessage); message WM_HOTKEY;
procedure WMMouseHook(var Msg: TMessage); message WM_MOUSEHOOK;
procedure EraseBkGnd(var Msg: TMessage); message WM_ERASEBKGND;
procedure DrawRect(pStart, pEnd: TPoint);
procedure CopyBitmap(pStart, pEnd: TPoint);
procedure DrawCurrsor;
public
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

function SetHook: Boolean; stdcall; external 'Project2.dll';

function UnHook: Boolean; stdcall; external 'Project2.dll';

procedure TForm1.FormCreate(Sender: TObject);
var
P: ^Cardinal;
begin
FMouseDown := False;
FEnable := False;
FBitmap := TBitmap.Create;
FClipboard := TClipboard.Create;
FScreenCanvas := TCanvas.Create;
FHotKeyID1 := GlobalAddAtom('F1');
FHotKeyID2 := GlobalAddAtom('F2');
if not RegisterHotKey(Handle, FHotKeyID1, MOD_CONTROL, VK_TAB) then
MessageBox(Handle, PChar('热键注册失败'), PChar('提示'), MB_OK);
if not RegisterHotKey(Handle, FHotKeyID2, MOD_CONTROL, Word('Q')) then
MessageBox(Handle, PChar('热键注册失败'), PChar('提示'), MB_OK);
FHFileMapping := CreateFileMapping(0, nil, PAGE_READWRITE, 0, SizeOf(Integer), MappingFileName);
P := MapViewOfFile(FHFileMapping, FILE_SHARE_WRITE, 0, 0, 0);
P^ := Handle;
if not SetHook then
MessageBox(Handle, PChar('安装钩子失败'), PChar('提示'), MB_OK);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
GlobalDeleteAtom(FHotKeyID1);
GlobalDeleteAtom(FHotKeyID2);
CloseHandle(FHFileMapping);
UnHook;
FScreenCanvas.Free;
FClipboard.Free;
FBitmap.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;

procedure TForm1.EraseBkGnd(var Msg: TMessage);
begin
;
end;

procedure TForm1.WMHotKey(var Msg: TMessage);
begin
case Msg.LParamHi of
VK_TAB:
begin
//DrawCurrsor;
FEnable := True;
Visible := True;
end;
Word('Q'): Close;
end;
end;

procedure TForm1.TBItem1Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.WMMouseHook(var Msg: TMessage);
begin
if not FEnable then Exit;
case Msg.WParam of
WM_LBUTTONDOWN:
begin
FMouseDown := True;
FPtStart.X := Msg.LParamLo;
FPtStart.Y := Msg.LParamHi;
FPtEnd.X := Msg.LParamLo;
FPtEnd.Y := Msg.LParamHi;
end;
WM_LBUTTONUP:
begin
FMouseDown := False;
DrawRect(FPtStart, FPtEnd);
CopyBitmap(FPtStart, FPtEnd);
FEnable := False;
Visible := False;
end;
WM_MOUSEMOVE:
begin
if FMouseDown then
begin
if (FPtStart.X <> FPtEnd.X) and (FPtStart.Y <> FPtEnd.Y) then
DrawRect(FPtStart, FPtEnd);
FPtEnd.X := Msg.LParamLo;
FPtEnd.Y := Msg.LParamHi;
if (FPtStart.X <> FPtEnd.X) and (FPtStart.Y <> FPtEnd.Y) then
DrawRect(FPtStart, FPtEnd);
end;
end;
end;
end;

procedure TForm1.DrawRect(pStart, pEnd: TPoint);
var
ARect: TRect;
begin
if pStart.X < pEnd.X then
begin
ARect.Left := pStart.X;
ARect.Right := pEnd.X;
end else
begin
ARect.Left := pEnd.X;
ARect.Right := pStart.X;
end;
if pStart.Y < pEnd.Y then
begin
ARect.Top := pStart.Y;
ARect.Bottom := pEnd.Y;
end else
begin
ARect.Top := pEnd.Y;
ARect.Bottom := pStart.Y;
end;
FScreenCanvas.Handle := GetDC(0);
FScreenCanvas.DrawFocusRect(ARect);
ReleaseDC(0, FScreenCanvas.Handle);
end;

procedure TForm1.CopyBitmap(pStart, pEnd: TPoint);
var
ARect: TRect;
begin
if pStart.X < pEnd.X then
begin
ARect.Left := pStart.X;
ARect.Right := pEnd.X;
end else
begin
ARect.Left := pEnd.X;
ARect.Right := pStart.X;
end;
if pStart.Y < pEnd.Y then
begin
ARect.Top := pStart.Y;
ARect.Bottom := pEnd.Y;
end else
begin
ARect.Top := pEnd.Y;
ARect.Bottom := pStart.Y;
end;
FBitmap.FreeImage;
FBitmap.Width := ARect.Right - ARect.Left;
FBitmap.Height := ARect.Bottom - ARect.Top;
FScreenCanvas.Handle := GetDC(0);
FBitmap.Canvas.CopyRect(Rect(0, 0, FBitmap.Width, FBitmap.Height), FScreenCanvas, ARect);
ReleaseDC(0, FScreenCanvas.Handle);
FClipboard.Assign(FBitmap)
end;

procedure TForm1.DrawCurrsor;
var
pt: TPoint;
ico: TIcon;
begin
if not GetCursorPos(pt) then Exit;
Application.ProcessMessages;
ico := TIcon.Create;
ico.Handle:= GetCursor;
FScreenCanvas.Draw(pt.X, pt.Y, ico);
ico.Free;
end;

end.
按热键Ctrl+Table开始,拉裁减框有了,获取裁剪框的图片也有了,自己需要Load张图片放窗体上,要把位图转换为jpg,我想可以不用转,直接用jpg的Canvas进行拷贝就行了。我是把截取的图放到了剪贴板
 
lake_cx:好文!
不过wbamboo已说了在图象上.所以,只考虑在图象上就可以了.(^-^)
1.在LeftButtonDown中记录选择框角点1的坐标(用全局变量较好).
2.在MouseMove中刷新对角点坐标
计算当前选择区域的大小:(10K,200K)
画出自己想要的选择框效果
3.条件符合
Bmp.Width/Height...
CopyRect(...)
搞定!
 
就是楼上说的那样。。。
不好意思,发了一大堆垃圾
 
谢谢两位。
scotte_wang,能否给我点示例代码,我比较笨的,折腾到现在还是没搞出来。
 
不好意思。
出差几天.
其实核心就一句话的.
还是哪个CopyRect(Dest,Canvas,Sourse);
关键:你只要把当前坐标拿到就可以了.
(55.我的系统要重装了..,所以不能先试一下)
可以加我:412001572.
互相学习吧.(你会了解的,我比你菜.嘿嘿).
 

Similar threads

D
回复
0
查看
2K
DelphiTeacher的专栏
D
D
回复
0
查看
1K
DelphiTeacher的专栏
D
D
回复
0
查看
1K
DelphiTeacher的专栏
D
D
回复
0
查看
851
DelphiTeacher的专栏
D
后退
顶部