- 14 Tháng năm 2017
- 3,974
- 7,623
- 744
- 22
- Phú Yên
- Trường THPT Lương Văn Chánh
[TẶNG BẠN] TRỌN BỘ Bí kíp học tốt 08 môn
Chắc suất Đại học top - Giữ chỗ ngay!!
ĐĂNG BÀI NGAY để cùng trao đổi với các thành viên siêu nhiệt tình & dễ thương trên diễn đàn.
Bây giờ mới thấy Pascal nó lợi hại đến mức nào. Cả Paint mà nó cũng làm được luôn nè 
Demo trước vài hình
(Cái này là lúc nó đang mở File)
(Cái này là nó mở xong rồi, mình vẽ trước rồi lưu lại )
(Cái này là mình chọn chế độ Xóa)
À quên nữa.....Bấm ESC để thoát chương trình nha
@ka1412 , @Nguyễn Tùng Ân
Mã:
Program Paint;
uses crt,dos,graph;
const
_Line = 1;
_Rectangle = 2;
_Ellipse = 3;
_Free = 4;
_Fill = 5;
_Clear = 6;
_MnX = 5;
_MnY = 105;
_MxX = 635;
_MxY = 455;
type TPoint = record
X1,Y1,X2,Y2: integer;
N: integer;
end;
var gd,gm: integer;
Pt,Pm: TPoint;
Shape : integer;
Col: Word;
Size: integer;
k: char;
f: Text;
function mousex:word;assembler;asm
mov ax,3; int 33h; mov ax,cx end;
function mousey:word;assembler;asm
mov ax,3; int 33h; mov ax,dx end;
function leftclick:boolean;assembler;asm
mov ax,3; int 33h; and bx,1; mov ax,bx end;
function MouseArea(x1,y1,x2,y2:word):boolean;
begin
if (LeftClick)
and (mousex >=x1)
and (mousex <=x2)
and (mousey >=y1)
and (mousey <=y2)
then mousearea:=true
else mousearea:=false;
end;
Function InitMouse : boolean;
var r: registers;
Begin
r.ax:=$00;intr($33,r);
if r.ax<>0 then InitMouse:=true
else InitMouse:=false;
End;
Procedure ShowMouse;
Var r: registers;
begin
r.ax:=$01;intr($33,r);
End;
Procedure HideMouse;
Var r:registers;
Begin
r.ax:=$002;
intr($33,r);
End;
Function PointNear(Cx,Cy: integer): Boolean;
var x,y: integer;
Begin
PointNear := False;
for x := Cx - 5 to Cx + 5 do
for y := Cy - 5 to Cy + 5 do
if (Mousex = x) and (Mousey = y) then PointNear := True;
End;
Procedure DrawMouse;
var x,y: string;
Begin
if (Mousex <> Pm.X1) or (Mousey <> Pm.Y1) then
begin
SetFillStyle(1,Black);
Bar(0,_MxY+5,639,479);
Str(Mousex-_MnX,X);
Str(Mousey-_MnY,y);
Pm.X1 := Mousex;
Pm.Y1 := Mousey;
OutTextXy(10,_MxY+10,X+' , ' + Y);
end;
End;
Procedure Choose(sh: integer);
Begin
HideMouse;
SetFillStyle(1,Black);
Bar(_MnX,81,_MxX,_MnY-7);
SetLineStyle(0,0,1);
SetFillStyle(1,Red);
SetColor(Red);
FillEllipse((sh-1)*80+40,90,5,5);
ShowMouse;
End;
Procedure DrawShape;
Begin
SetColor(White);
SetLineStyle(0,0,3);
RecTangle(0,0,639,_MnY-5);
RecTangle(0,_MnY-5,639,_MxY+5);
SetLineStyle(0,0,1);
RecTangle(10,20,70,80);
RecTangle(90,20,150,80);
RecTangle(170,20,230,80);
RecTangle(250,20,310,80);
RecTangle(330,20,390,80);
RecTangle(410,20,470,80);
RecTangle(490,20,550,80);
RecTangle(570,20,630,80);
SetLineStyle(0,0,3);
Line(15,25,65,75);
Rectangle(100,30,140,70);
Circle(200,50,20);
Line(255,25,270,35);
Line(270,35,263,55);
Line(263,55,305,75);
SetFillStyle(1,White);
Bar(350,40,370,70);
Bar(340,30,370,40);
SetFillStyle(1,Col);
Bar(420,30,460,70);
SetFillStyle(1,White);
FillEllipse(520,50,Size*7,Size*7);
OutTextXy(580,45,'Clear');
End;
Procedure Draw;
Begin
HideMouse;
SetColor(White);
SetLineStyle(0,0,Size);
case Shape of
_Line: if Pt.N = 2 then begin Line(Pt.X1,Pt.Y1,Pt.X2,Pt.Y2);Pt.N := 0;end;
_RecTangle: if Pt.N = 2 then begin RecTangle(Pt.X1,Pt.Y1,Pt.X2,Pt.Y2);Pt.N := 0;end;
_Ellipse: if Pt.N = 2 then begin Ellipse((Pt.X1+Pt.X2) div 2,
(Pt.Y1+Pt.Y2) div 2,0,360,
abs(Pt.X2 - Pt.X1) div 2,abs(Pt.Y2 - Pt.Y1) div 2);
PutPixel(Pt.X1,Pt.Y1,Black);Pt.N := 0;end;
_Free: if (Pt.N <> 0) and (Pt.X2 > 1) then begin
Line(Pt.X1,Pt.Y1,Pt.X2,Pt.Y2);
if Pt.N = 2 then Pt.N := 0;end;
_Fill: begin PutPixel(Pt.X1,Pt.Y1,Col);
SetFillStyle(1,Col);FloodFill(Pt.X1+1,Pt.Y1+1,White);Pt.N:=0;end;
_Clear: if (Pt.N <> 0) and (Pt.X1 >= _MnX+3*Size)
and (Pt.Y1 >= Size*3+_MnY) then begin SetFillStyle(1,Black);
SetColor(Black);
FillEllipse(Pt.X1,Pt.Y1,3*Size,3*Size);Pt.N := 0;end;
end;
ShowMouse;
End;
Procedure GetShape;
Begin
if MouseArea(10,20,70,80) then begin Shape := _Line;Pt.N:=0;Choose(1);end
else
if MouseArea(90,20,150,80) then begin Shape := _RecTangle;Pt.N:=0;Choose(2);end
else
if MouseArea(170,20,230,80) then begin Shape := _Ellipse;PT.N:=0;Choose(3);end
else
if MouseArea(250,20,310,80) then begin Shape := _Free;Pt.X2 := 0;Pt.N:=0;choose(4);end
else
if MouseArea(330,20,390,80) then begin Shape := _Fill;Pt.N:=0;choose(5);end
else
if MouseArea(410,20,470,80) then
begin
inc(col);
if col > 15 then Col := 1;
HideMouse;
SetFillStyle(1,Col);
Bar(420,30,460,70);
ShowMouse;
end
else
if MouseArea(490,20,550,80) then
begin
inc(Size,2);
if Size > 3 then Size := 1;
HideMouse;
SetFillStyle(1,Black);
Bar(491,21,549,79);
SetFillStyle(1,white);
SetColor(White);
FillEllipse(520,50,Size*7,Size*7);
ShowMouse;
end
else
if MouseArea(570,20,630,80) then begin Shape := _Clear;Pt.N:=0;Choose(8);end;
End;
Procedure GetPoint;
Begin
if LeftClick then
begin
if (Pt.N = 0) and not PointNear(Pt.X2,Pt.Y2) then
begin Pt.X1 := Mousex-1;Pt.Y1 := Mousey-1;
Pt.N := 1;PutPixel(Mousex-1,Mousey-1,White);end
else
if (Pt.N = 1) and not PointNear(Pt.X1,Pt.Y1) then
begin Pt.X2 := Mousex;Pt.Y2 := Mousey;
Pt.N := 2;end;
end;
Draw;
End;
Procedure Save;
var x,y,c: integer;
Begin
HideMouse;
OutTextXy(150,_MxY+10,'Saving...');
ReWrite(f);
for x := _MnX to _MxX do
for y := _MnY to _MxY do
begin
c := GetPixel(x,y);
writeln(f,c);
end;
Close(f);
sound(1000);
Delay(100);
Nosound;
ShowMouse;
DrawMouse;
End;
Procedure Open;
var x,y,c,code: integer;
s: string;
Begin
HideMouse;
Reset(f);
OutTextXy(150,_MxY+10,'Opening...');
for x := _MnX to _MxX do
for y := _MnY to _MxY do
begin
Readln(f,s);
Val(s,c,Code);
if Code = 0 then
PutPixel(x,y,c)
else begin break;x := 635;end;
end;
Close(f);
sound(1000);
Delay(100);
Nosound;
ShowMouse;
DrawMouse;
End;
Procedure Start;
Begin
Shape := _Line;
Col := white;
Size := 1;
Pt.N := 0;
Choose(1);
Assign(f,'Picture.txt');
End;
BEGIN
InitGraph(gd,gm,'');
InitMouse;
ShowMouse;
Start;
DrawShape;
repeat
if (Mousex >= _MnX) and (MouseX <= _MxX) and
(Mousey >= _MnY) and (Mousey <= _MxY) then
DrawMouse;
k := #0;
if Keypressed then k := readkey;
GetShape;
if MouseArea(_MnX,_MnY,_MxX,_MxY) then
GetPoint;
if k = 's' then Save
else if k = 'o' then Open;
until k = #27;
CloseGraph;
END.Từ trái sang phải lần lượt là
1) Đường thẳng: Cần tọa độ 2 điểm để vẽ. Các bạn chấm 2 điểm thì nó sẽ vẽ một đường màu trắng, không có màu khác nha.
2) Hình chữ nhật: Cũng cần tọa độ 2 điểm để vẽ, đó là tọa độ 2 đỉnh đối của hình chữ nhật.
3) Hình Ellipse: Cũng cần tọa độ 2 điểm để vẽ. Hình Ellipse vẽ được sẽ nội tiếp hình chữ nhật với 2 điểm mà mình đã chấm.
4) Vẽ tự do: Cứ mỗi lần Click chuột trên màn hình thì nó sẽ nối điểm trước đó với điểm mình Click, để Vẽ hình mới thì cần phải Click lại ô này một làn nữa.
5,6) Tô màu: Màu sắc sẽ được chọn ở ô thứ 6, Click vào hình kín để tô màu.
7) Kích thước đường: Click vào thì nó sẽ thay đổi kích thước đường mình vẽ ra.
8) Xóa: Click vào một điểm thì nó sẽ tạo một đường tròn màu đen có tâm là điểm mình Click để xóa hình.
Ngoài ra nó còn có thể Lưu hình mình vẽ rồi mở lên.
Bấm "s" để lưu hình,"o" để mở hình, sau khi thực hiện xong nó sẽ có tiếng "bip". Vì nó lưu hơi lâu nên mình làm vậy để biết khi nào nó làm xong.
1) Đường thẳng: Cần tọa độ 2 điểm để vẽ. Các bạn chấm 2 điểm thì nó sẽ vẽ một đường màu trắng, không có màu khác nha.
2) Hình chữ nhật: Cũng cần tọa độ 2 điểm để vẽ, đó là tọa độ 2 đỉnh đối của hình chữ nhật.
3) Hình Ellipse: Cũng cần tọa độ 2 điểm để vẽ. Hình Ellipse vẽ được sẽ nội tiếp hình chữ nhật với 2 điểm mà mình đã chấm.
4) Vẽ tự do: Cứ mỗi lần Click chuột trên màn hình thì nó sẽ nối điểm trước đó với điểm mình Click, để Vẽ hình mới thì cần phải Click lại ô này một làn nữa.
5,6) Tô màu: Màu sắc sẽ được chọn ở ô thứ 6, Click vào hình kín để tô màu.
7) Kích thước đường: Click vào thì nó sẽ thay đổi kích thước đường mình vẽ ra.
8) Xóa: Click vào một điểm thì nó sẽ tạo một đường tròn màu đen có tâm là điểm mình Click để xóa hình.
Ngoài ra nó còn có thể Lưu hình mình vẽ rồi mở lên.
Bấm "s" để lưu hình,"o" để mở hình, sau khi thực hiện xong nó sẽ có tiếng "bip". Vì nó lưu hơi lâu nên mình làm vậy để biết khi nào nó làm xong.
Demo trước vài hình
(Cái này là lúc nó đang mở File)
(Cái này là nó mở xong rồi, mình vẽ trước rồi lưu lại
) (Cái này là mình chọn chế độ Xóa)
À quên nữa.....Bấm ESC để thoát chương trình nha
@ka1412 , @Nguyễn Tùng Ân
