DELPHI写的截图小工具源码（部分）
unit ImageJT;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ExtCtrls, StdCtrls, DB, ADODB,ShellAPI,Clipbrd, pngimage;
type
TForm1 = class(TForm)
Image1: TImage;
PaintBox1: TPaintBox;
MainMenu1: TMainMenu;
N1: TMenuItem;
ScrollBox1: TScrollBox;
OpenDialog1: TOpenDialog;
Button1: TButton;
SaveDialog1: TSaveDialog;
Edit1: TEdit;
Edit2: TEdit;
ADOC1: TADOConnection;
Q1: TADOQuery;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
Image2: TImage;
procedure N1Click(Sender: TObject);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure PaintBox1Paint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure SaveTxt(logname,logpath,Ftxt :string);
procedure N2Click(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure N3Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N5Click(Sender: TObject);
private
//截屏的坐标，路径
procedure SnapScreen(a, b, c, d: Integer; Apath: string);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Re,Arect:TRect;
point:TPoint;
BeginX,BeginY,Endx,EndY:integer;
jtks:Boolean=False; //截图开始
cztx:Boolean=False; //重置图像
ifsd:Boolean=False; //锁定起点
implementation
uses GIFImg,jpeg,ckImage,Unit2,AddBl;
{$R *.dfm}
//保存记录到文本
procedure TForm1.SaveTxt(logname,logpath,Ftxt :string);
var
f:TextFile;
hile: Thandle;
begin
//判断是否有文本
if not FileExists(logpath+'\log.txt') then
begin
//创建文本
hile :=FileCreate(logpath+'\log.txt');
CloseHandle(hile);
end;
//Ftxt:=inputbox('输入','请输入名字','');
assignfile(f,logpath+'\log.txt');
Append(f);
Writeln(f,datetimetostr(now)+'插入描述：'+Ftxt+'截图：'+logname+'.jpg'+'原图：'+logname+'yt.jpg');
closeFile(f);
end;
//任意区域截图,参数为截图坐标
procedure TForm1.SnapScreen(a, b, c, d: Integer; Apath: string);
var
bmpscreen,b1:Tbitmap;
// jgpscreen:TJPEGImage; \
FullscreenCanvas:TCanvas;
dc:HDC;
sourceRect, destRect: TRect;
begin
//dc:=getdc(0); 获取屏幕的句柄
fullscreencanvas:=Tcanvas.Create;
//获取图片的句柄
fullscreencanvas.Handle:=Image1.Canvas.Handle;
bmpscreen:=Tbitmap.create;
b1:=Tbitmap.Create;
bmpscreen.Width:=abs(c-a);
bmpscreen.Height:=abs(d-b);
sourcerect:=Rect(0,0,c-a,d-b);//创建一个与截图同样大小的图
destrect:= Rect(a,b,c,d);//实际截图的位置
bmpscreen.Canvas.CopyRect(sourcerect,fullscreenCanvas,destrect);
//bmp转换为jpg --b1改为JPG 后就可以直接用，现在改为BMP格式的还是使用的转换代码
b1.Assign(bmpscreen);
//图片保存到本地
b1.SaveToFile(Apath);
FullscreenCanvas.Free;
bmpscreen.Free;
b1.Free;
//ReleaseDC(0, DC);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
filename,logname:string;
filejpg,reImage: TImage;
Stream:TMemoryStream;
blms,blmc:string;
begin
if jtks then
begin
logname:=formatdatetime('yymmddhhmmss',now);
filename:=ExtractFilePath(Application.ExeName)+'image\'+formatdatetime('yyyymmdd',now)+'\';
if not DirectoryExists(filename) then
begin
ForceDirectories(filename);
// CreateDir(filename);
end;
SnapScreen(Arect.Left,Arect.Top,Arect.Right,Arect.Bottom,FileName+logname+'.bmp' );
{ SaveDialog1.FileName:=FileName+logname+'.jpg' ;
//图片保存到本地
if not SaveDialog1.Execute then
begin
DeleteFile(ExtractFilePath(Application.ExeName)+'\Cut.jpg');
Exit;
end; }
{ if FileExists(FileName+logname+'.jpg') then
begin
CopyFile(PChar(FileName+logname+'.jpg'),PChar(SaveDialog1.FileName),False);
end ; }
//取本地图片加载后存储到数据库
filejpg:=TImage.Create(self);
if FileExists(FileName+logname+'.bmp') then
begin
filejpg.Picture.LoadFromFile(FileName+logname+'.bmp');
end else
begin
MessageBox(Handle,'错误信息','图片截取失败请判断图片是否截取!',MB_ICONEXCLAMATION);
//DeleteFile(ExtractFilePath(Application.ExeName)+'\Cut.jpg');
exit;
end;
Form2:=TForm2.Create(nil);
if Form2.ShowModal=mrCancel then
begin
form2.Free;
//DeleteFile(ExtractFilePath(Application.ExeName)+'\Cut.jpg');
//ShowMessage('123');
Exit;
end;
blms:=Form2.memo1.Text;
blmc:=Form2.Edit2.Text;
q1.Close;
q1.SQL.Clear;
q1.SQL.Text:='select * from t2_image where 1=0';
q1.open;
q1.Append;
q1.FieldByName('sj').Value:=FormatDateTime('yyyy-mm-dd hh:nn:ss',now);
Q1.FieldByName('image').Assign(filejpg.Picture.Graphic);
Q1.FieldByName('blms').value:=blms;
Q1.FieldByName('blmc').value:=blmc;
Q1.FieldByName('x1').value:=Arect.Left;
Q1.FieldByName('y1').value:=Arect.Top;
Q1.FieldByName('x2').value:=Arect.Right;
Q1.FieldByName('y2').value:=Arect.top;
Q1.FieldByName('x3').value:=Arect.Left;
Q1.FieldByName('y3').value:=Arect.Bottom;
Q1.FieldByName('x4').value:=Arect.Right;
Q1.FieldByName('y4').value:=Arect.Bottom;
Q1.FieldByName('YTNamePath').value:=FileName+logname+'yt.bmp';
Q1.FieldByName('YTfilepath').value:=FileName+logname+'ytzb.bmp';
Q1.FieldByName('filepath').value:=FileName+logname+'.bmp';
q1.Post;
if Q1.RecordCount>0 then
begin
SaveTxt(logname,FileName,blms);
//button1.Visible:=False;
Image2.Visible:=False;
MessageBox(Handle,'保存成功！','提示',0);
end else
begin
MessageBox(Handle,'保存失败！','提示',0);
end;
// CopyFile(PChar(ExtractFilePath(Application.ExeName)+'\Cut.jpg'),PChar(SaveDialog1.FileName),False);
// DeleteFile(ExtractFilePath(Application.ExeName)+'\Cut.jpg');
//保存带矩形的原图
reImage:=TImage.Create(nil);
reImage.Picture.Bitmap.Assign(Image1.Picture.Graphic);
reImage.Canvas.Brush.Style:=bsClear;
reImage.Canvas.Pen.Color:=clRed;
reImage.Canvas.Rectangle(Arect);
reImage.Canvas.Font.Size:=12;
reImage.Canvas.TextOut(0,0,'截图矩形坐标值：('+inttostr(Arect.Left)+','+inttostr(Arect.Top)+')'
+'('+inttostr(Arect.Right)+','+inttostr(Arect.top)+')'
+'('+inttostr(Arect.Left)+','+inttostr(Arect.Bottom)+')'
+'('+inttostr(Arect.Right)+','+inttostr(Arect.Bottom)+')');
reImage.Picture.SaveToFile(FileName+logname+'ytzb.bmp'); //保存原图
Image1.Picture.SaveToFile(FileName+logname+'yt.bmp');
jtks:=False;
cztx:=True;
ifsd:=False;
Form2.Free;
filejpg.Free;
end else
begin
MessageBox(Handle,'请先选择图片','错误',MB_ICONEXCLAMATION) ;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
dataSource:string;
begin
DoubleBuffered:=True;
dataSource:=ExtractFilePath(Application.ExeName)+'\tpdb.mdb';
try
ADOC1.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Data Source='''+dataSource+''';Persist Security Info=False' ;
ADOC1.Connected:=True;
except
ShowMessage('数据库连接失败！');
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key=13 then
Button1.Click;
if Key=27 then
begin
ifsd:=False;
end;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
ScrollBox1.Width:=form1.ClientWidth;
ScrollBox1.Height:=form1.ClientHeight;
end;
procedure TForm1.N1Click(Sender: TObject);
var
filename,ext:string;
png:TPngImage;
jpg:TJpegImage;
begin
OpenDialog1.Filter:='图片文件|*.jpg;*.bmp;*.png;*.jpeg' ;
if OpenDialog1.Execute then
begin
//获取文件路径
filename:=OpenDialog1.FileName;
ext:=ExtractFileExt(filename);
//InputBox('','',filename);
//判断后缀是什么
if ext='.bmp' then
begin
Image1.Picture.LoadFromFile(filename);
end else
if ext='.png' then
begin
png:=TPngImage.Create;
png.LoadFromFile(filename);
Image1.Picture.Bitmap.Assign(png);
png.Free
end else
if (ext='.jpg') or (ext='jpeg') then
begin
jpg:=TJPEGImage.Create;
jpg.LoadFromFile(filename);
Image1.Picture.Bitmap.Assign(jpg);
jpg.Free;
end;
PaintBox1.Width:=Image1.Width;
PaintBox1.Height:=Image1.Height;
end;
end;
procedure TForm1.N2Click(Sender: TObject);
begin
ckima:=Tckima.Create(self);
ckima.ShowModal;
ckima.Free;
end;
procedure TForm1.N3Click(Sender: TObject);
begin
ShellAbout( Self.Handle,PChar('截图工具'),
PChar('Delphi截图V1.0 QQ:283365011'+#13+'帮助：ENTER为保存,查看图片点击右键删除'),
HICON(nil)
) ;
end;
procedure TForm1.N4Click(Sender: TObject);
begin
AddBlzd:=TAddBlzd.Create(nil);
AddBlzd.ShowModal;
AddBlzd.Free;
end;
procedure TForm1.N5Click(Sender: TObject);
var
bit: TBitmap;
begin
if not Clipboard.HasFormat(CF_BITMAP) then Exit;
bit := TBitmap.Create;
bit.Assign(Clipboard);
Image1.Picture.Bitmap.Assign(bit);
PaintBox1.Width:=Image1.Width;
PaintBox1.Height:=Image1.Height;
end;
procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (ssShift in Shift) and (ifsd=False) then
begin
ifsd:=True;
//re:=Rect(X,Y,X,Y);
Arect:=Rect(X,Y,X,Y);
jtks:=True;
BeginX:=X;
BeginY:=Y;
cztx:=False;
//Button1.Visible:=True;
Image2.Visible:=True;
end;
end;
procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if (ssLeft in Shift) and (jtks=true) then
begin
if x>image1.Width then
begin
endx:=image1.Width
end else
if x<0 then
begin
endx:=1;
end else
begin
endx:=x;
end;
if y>image1.Height then
begin
endy:=image1.Height;
end else
if y<0 then
begin
endy:=1
end else
begin
endy:=y;
end;
//Re.Right:=endx;
//Re.Bottom:=endy;
//Arect.Left:=BeginX; //取消锁定起点
//Arect.Top:=BeginY; //取消锁定起点
Arect.Right:=endx;
Arect.Bottom:=endy;
//Edit1.Text:=IntToStr(PaintBox1.Width);
//Edit2.Text:=IntToStr(PaintBox1.Height);
//Re.Right:=endy;
//Re.Bottom:=endy;
PaintBox1.Canvas.Brush.Style:=bsClear;
PaintBox1.Canvas.Rectangle(Arect);
//InvalidateRect(form1.Handle,Re ,TRUE);
//窗体创建DoubleBuffered:=True; 防止闪图
PaintBox1.Invalidate;
end else
begin
if cztx then
PaintBox1.Invalidate;
end;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
tsX,tsY:Integer;
begin
PaintBox1.Width:=Image1.Width;
PaintBox1.Height:=Image1.Height;
tsX:=endx+5;
tsY:=endY+5;
if jtks then
begin
PaintBox1.Canvas.Brush.Style:=bsClear;
PaintBox1.Canvas.Pen.Color:=clRed;
PaintBox1.Canvas.Rectangle(Arect);
if (endx+200)>Image1.Width then
begin
tsx:=tsX-200;
end;
if (tsY+50)>Image1.Height then
begin
tsY:=tsY-50;
end;
PaintBox1.Canvas.TextOut(tsX,tsY,'保存请按ENTER!');
PaintBox1.Canvas.TextOut(tsX,tsY+15,'('+inttostr(Arect.Left)+','+inttostr(Arect.Top)+')'
+'('+inttostr(Arect.Right)+','+inttostr(Arect.top)+')'
+'('+inttostr(Arect.Left)+','+inttostr(Arect.Bottom)+')'
+'('+inttostr(Arect.Right)+','+inttostr(Arect.Bottom)+')'
);
Image2.Top:=Arect.Bottom;
Image2.Left:=Arect.Right;
form1.Caption:='截图工具（按住SHIFT+鼠标左键选择起点;ESC取消起点锁定)'+' '
+'('+inttostr(Arect.Left)+','+inttostr(Arect.Top)+')'
+'('+inttostr(Arect.Right)+','+inttostr(Arect.top)+')'
+'('+inttostr(Arect.Left)+','+inttostr(Arect.Bottom)+')'
+'('+inttostr(Arect.Right)+','+inttostr(Arect.Bottom)+')'
end;
end;
end.
//第一次完整的写Delphi小工,纪念一下,代码写的很烂请不要见怪。
|
|
联系电话：
020-00000000
联系电话：
020-00000000
联系电话：
020-12345678