Đề tài Thiết kế và thi công máy chấm điểm trắc nghiệm giao tiếp máy vi tính
Dòng 1: Procedure CK; –Khai báo tên thủ tục, khi cần gọi thủ tục này ta chỉ cần gọi tên trực tiếp trong chương trình chính (hay thủ tục hay hàm khác). Đây là một thủ tục không có tham số. Dòng 2: Var –Thông báo: bắt đầu khai báo biến cục bộ. Dòng 3: I:Byte; –Khai báo một biến tên là “I” kiểu Byte (chiều rộng từ dữ liệu là 08 bit). Biến này dùng cho con chạy của dòng For. Do giới hạn dòng chạy của dòng For chỉ là 6 bước nên chọn I kiểu byte (giá trị lớn nhất là 255). Dòng 4: Begin –Khai báo bắt đầu phần chương trình của thủ tục. Dòng 5: DataA:=DataA and $C0; –Xóa dữ liệu Data A, giữ lại giá trị của hai bit 6 và 7 (DataA6: điều khiển động cơ DC1; DataA7: điều khiển động cơ DC1). Thực hiện điều này bằng cách AND dữ liệu DataA với giá trị $C0 (Giá trị thập lục phân: $C0 chuyển sang giá trị nhị phân là : 1100000B).
Bạn đang xem trước 20 trang tài liệu Đề tài Thiết kế và thi công máy chấm điểm trắc nghiệm giao tiếp máy vi tính, để xem tài liệu hoàn chỉnh bạn click vào nút DOWNLOAD ở trên
ey = $7300 ; CtrlRightKey = $7400;
CtrlHomeKey = $7700 ; CtrlEndkey = $7500;
CtrlPgUp = $8400 ; CtrlPgDnKey = $7600;
TYPE
MenuPtr = ^Menutype ;
MenuItem = Record
Name : String[50];
Hkey : Word ;
Case Pop : Boolean Of
True : (SubMenu : MenuPtr) ;
End;
ListType = Array[1..MaxItem] of MenuItem;
Menutype = Record
Size : Byte ;
List : ListType;
End;
{$F+}
Procedure InitVar( Var M : MenuPtr);
Procedure DeInitVar( Var M : MenuPtr);
Procedure AppendItem(Name : String ; HKey : Word;
Pop : Boolean ; SMenu : MenuPtr;
Var M : MenuPtr);
Function MenuOnePos(x,y,IAttr:Byte;M : MenuPtr): Word ;
Function Menubar(x,y,LAttr,NAttr,IAttr:Byte;M:MenuPtr):Word ;
Function Menupop(x,y,LAttr,NAttr,IAttr:Byte;M:MenuPtr):Word ;
Function MenuPullDown(x,y,LAttr,NAttr,IAttr : Byte;
M:MenuPtr) : Word ;
Function MenuDos(Col,Row,ColNum,RowNum,
FrAttr,NAttr,IAttr : Byte ;
Path : PathStr): PathStr;
{$F-}
IMPLEMENTATION
Uses Crt,Ptool ;
{$S-}
Var Right , Left : Boolean ;
CSize : Word ;
Function RPad(St:String ;N : Byte): String ;
Var Len : Byte Absolute St ;
Begin
While Len < N do St := St+#32;
RPad := St ;
End;
Function MaxLength( P : MenuPtr ) : Byte ;
Var Tempo , I : Byte ;
Begin
Tempo := 0;
For i := 1 to P^.Size do
If Tempo < Length(P^.List[i].Name) then
Tempo := Length(P^.List[i].Name) ;
MaxLength := Tempo ;
End;
{--------------------------------------------------}
Function GetKey : Word ;
Var Ch : Char ;
Begin
Ch := Readkey ;
If Ord(Ch) = NUL then
Getkey := Word(Ord(Readkey)) Shl 8
else
Getkey := Ord(Ch);
End;
{--------------------------------------------------}
Procedure InitVar( Var M : MenuPtr);
var i : Byte ;
Begin
New(M);
M^.Size := 0;
For i := 1 to MaxItem do
with M^.List[i] do
begin
Name :='' ;
Hkey := Nul ;
Pop := False ;
end;
End;
{--------------------------------------------------}
Procedure DeInitVar( Var M : MenuPtr);
Begin
Dispose(M);
End;
{--------------------------------------------------}
Procedure AppendItem(Name : String ; HKey : Word;
Pop : Boolean ; SMenu : MenuPtr;
Var M : MenuPtr);
Begin
If M^.Size < MaxItem then
Begin
Inc(M^.Size);
M^.List[M^.Size].Name := Name ;
M^.List[M^.Size].HKey := Hkey ;
M^.List[M^.Size].Pop := Pop ;
If Pop then
M^.List[M^.Size].SubMenu := SMenu;
End;
End;
{--------------------------------------------------}
Function FindHotKey(M:MenuPtr;Nk:Word;Var N : Word):Boolean;
Var i : Byte ;
Begin
i := 1 ;
While (i M^.List[i].Hkey) do Inc(i);
If i <= M^.Size then
Begin
FindHotKey := True ; N := i ;
end
Else FindHotKey := False;
End;
{--------------------------------------------------}
Function FindUpChr(St:String):Byte ;
Var i : Byte ;
Begin
i := 1 ;
While (i<=Length(st)) and
((St[i]'Z')) do Inc(i);
If i > Length(St) then FindUpChr := 0
Else FindUpChr := i ;
End;
{--------------------------------------------------}
Function MenuOnePos(x,y,IAttr:Byte;M : MenuPtr): Word ;
var MLen : Byte ;
N,Nk : Word ;
Thoat : Boolean ;
{--------------------------------------------------}
Procedure WriteItem(k:Byte);
Begin
If k > 0 then
WriteStr(x,y,IAttr,RPad(M^.List[k].Name,MLen));
End;
{-----------------------------------------------------}
Begin
CursorOff;
Mlen := MaxLength(M);
Thoat := False ;
N := 1;
WriteItem(N);
Repeat
Nk := GetKey ;
Case Nk of
UpKey,LeftKey :
If N>1 then Dec(N) else N := M^.Size;
DownKey,RightKey :
If N<M^.Size then Inc(N) else N := 1;
HomeKey : N := 1;
EndKey : N := M^.Size ;
Enter : Thoat := True ;
Esc : Begin Thoat := True ;N := 0 end;
end;
WriteItem(N);
Until Thoat ;
MenuOnePos := N ;
SetCurSor(CSize);
End;
{--------------------------------------------------}
Function Menubar(x,y,LAttr,NAttr,IAttr : Byte ;
M : MenuPtr): Word ;
Var Nk , N : Word ;
Thoat : Boolean ;
{--------------------------------------------------}
Procedure WriteItem( k : Byte ; Active : Boolean);
Var Col,Len,i,N : Byte ;
Begin
Len := 0;
For i := 1 to k - 1 do
Len := Len + Length(M^.List[i].Name) + 2;
Col := x + Len;
If Active then
WriteStr(Col,Y,IAttr,M^.List[k].Name)
Else
begin
WriteStr(Col,Y,NAttr,M^.List[k].Name);
N := FindUpChr(M^.List[k].Name);
If N 0 then
WriteStr(Col+N-1,Y,LAttr,M^.List[k].Name[N]);
end;
End;
{--------------------------------------------------}
Procedure Table ;
Var i : Byte ;
Begin
For i := 1 to M^.Size do WriteItem(i,False);
End;
{-----------------------------------------------------}
Begin
CurSorOff;
Table;
If (NM^.Size) then N := 1;
Thoat := False ;
Repeat
WriteItem(N,True);
Nk := GetKey ;
WriteItem(N,False);
If FindHotKey(M,Nk,N) then
Thoat := True
Else
Case Nk of
Leftkey :If N > 1 then dec(N) else N := M^.Size;
RightKey :If N < M^.Size then Inc(N) else N := 1;
HomeKey : N := 1;
EndKey : N := M^.Size;
Enter : Thoat := True ;
Esc : begin
Thoat := True;
N := 0
end;
end;
Until thoat ;
MenuBar := N;
SetCurSor(CSize);
End;
{--------------------------------------------------}
Function Menupop(x,y,LAttr,NAttr,IAttr:Byte;M:MenuPtr):Word ;
Var Nk : Word ;
MLen,N,SubN : Word ;
Thoat : Boolean ;
Sc : ScrPtr;
x1,y1,x2,y2 : Integer ;
Procedure WriteItem(k : Byte ; Active : Boolean );
Var Col,row : Byte ;
N : Word ;
Begin
Col := x1 + 2 ; Row := y1 + k ;
If Active then
WriteStr(Col,Row,IAttr,RPad(M^.List[k].Name,MLen))
Else
begin
WriteStr(Col,Row,NAttr,
RPad(M^.List[k].Name,MLen));
If M^.List[k].HKey Nul then
Begin
N := FindUpChr(M^.List[k].Name);
If N 0 then
WriteStr(Col+N-1,Row,LAttr,
M^.List[k].Name[N]);
end;
end;
End;
Procedure Table ;
Var i : Byte ;
Begin
MLen := MaxLength(M);
x1 := x ; y1 := y ;
Repeat
x2 := x1 + Mlen+3;
If x2 > 78 then dec(x1);
Until x2 <= 78 ;
Repeat
y2 := y1 + M^.Size + 1;
if y2 > 23 then dec(y1);
Until y2 <= 23;
Box(x1,y1,x2,y2,NAttr,Single,ShadeOn);
For i := 1 to M^.Size do WriteItem(i,False);
end;
{--------------------------------------------------}
Procedure ChangeItem;
Begin
Case Nk of
Upkey : If N>1 then dec(N) else N := M^.Size;
DownKey: If N<M^.Size then Inc(N) else N := 1;
Esc :
begin
Thoat := True;N := 0 ;
end;
Leftkey:
begin
Thoat := True;N := 0 ;Left := True ;
end;
Rightkey :
begin
Thoat := True;N := 0 ;Right := True;
end;
Enter : begin
If M^.List[N].Pop then
Begin
{ Gäi Menu Con }
SubN := MenuPop(x1+2+4,y1+N+1,
LAttr,NAttr,IAttr,
M^.List[N].SubMenu);
If SubN 0 then thoat := True;
End
Else
Thoat := True ;
End;
End;
End;
{-----------------------------------------------------}
Begin
SaveScreen(Sc);
CurSorOff;
Table;
Thoat := False ;
N := 1;
Repeat
SubN := 0;Left := False ; Right := False ;
WriteItem(n,True);
Nk := GetKey ;
WriteItem(N,False);
If FindHotKey(M,Nk,N) then
If M^.List[N].Pop then
Begin
{ Gäi Menu con khi B½m phÝm Hot-Key }
SubN := MenuPop(x1+2+4,y1+N+1,LAttr,
NAttr,IAttr,M^.List[N].SubMenu);
If SubN 0 then thoat := True ;
End
Else
Thoat := True
Else ChangeItem
Until thoat ;
RestoreScreen(Sc);
If SubN = 0 then MenuPop := N
Else
If (SubN and $FFF0 ) = 0 then
MenuPop := N Shl 4 + SubN
Else
If (SubN and $FF00 ) = 0 then
MenuPop := N Shl 8 + SubN
Else
If (SubN and $F000 ) = 0 then
MenuPop := N Shl 12 + SubN ;
SetCurSor(CSize);
End;
{--------------------------------------------------}
Function MenuPullDown(x,y,LAttr,NAttr,IAttr : Byte;
M:MenuPtr) : Word ;
Var SubN , N ,Nk : Word ;
Thoat, PopActive : Boolean ;
{--------------------------------------------------}
Function ItemCol(k : Byte ): Byte ;
Var Len,i : Byte ;
Begin
Len := 0 ;
For i := 1 to k - 1 do
Len := Len+Length(M^.List[i].Name)+2;
ItemCol := x + Len ;
End;
{---------------------------------------------------}
Procedure WriteItem(k:Byte;Active:Boolean);
Var Col,N : Byte ;
Begin
If k 0 then
Begin
Col := ITemCol(k) ;
If Active then
WriteStr(Col,Y,IAttr,M^.List[k].Name)
Else
begin
WriteStr(Col,Y,NAttr,M^.List[k].Name);
N := FindUpChr(M^.List[k].Name);
If N 0 then
WriteStr(Col+N-1,Y,LAttr,
M^.List[k].Name[N]);
end;
End;
End;
{--------------------------------------------------}
Procedure Table ;
Var i : Byte ;
Begin
For i := 1 to M^.Size do WriteItem(i,False);
End;
{-----------------------------------------------------}
Begin
CurSorOff;
PopActive := False;
Thoat := False ;
Table;
If (NM^.Size) then N := 1;
Repeat
SubN := 0;
WriteItem(N,True);
If PopActive and M^.List[N].Pop and
(M^.List[N].Submenu Nil) then
SubN := Menupop(ItemCol(N),y+1,
LAttr,NAttr,IAttr,M^.List[N].Submenu);
If (SubN = 0) and (Not Left) and (Not Right) then
PopActive := False ;
If PopActive and M^.List[N].Pop and
(M^.List[N].Submenu Nil) then
begin
if Left then Nk := LeftKey;
If Right then Nk := Rightkey;
WriteItem(N,False);
end
else
begin
Nk := GetKey ;
WriteItem(N,False);
If FindHotKey(M,Nk,N) then Nk := Enter;
end;
Case Nk of
LeftKey :If N>1 then dec(N) else N := M^.Size;
RightKey :If N<M^.Size then Inc(N) else N := 1;
Esc :begin
Thoat := True;N := 0
end;
Enter : If (M^.List[N].Pop) then
PopActive := True
else
Thoat := True ;
End;
Until Thoat or ( SubN 0) ;
If SubN and $FFFF = 0 then
MenuPulldown := N
Else
If SubN and $FFF0 = 0 then
MenuPulldown := (N shl 4 ) + SubN
Else
If SubN and $FF00 = 0 then
MenuPulldown := (N shl 8 ) + SubN
Else
If SubN and $F000 = 0 then
MenuPulldown := (N shl 12 ) + SubN;
SetCurSor(CSize);
End;
Function MenuDos(Col,Row,ColNum,RowNum,
FrAttr,NAttr,IAttr : Byte ;
Path : PathStr): PathStr;
Type
DirPtr = ^DirRec;
DirRec = Record
Name : String[12];
FileAttr : Byte ;
Pre,Next : DirPtr ;
End;
Const
{----------------------------------------------------}
Left = #75; Right = #77; Up = #72; Down = #80 ;
Home = #71; Endkey = #79; PgUp = #73; PgDn = #81 ;
Esc = #27; Enter = #13;
Var
First,Last,P,Heap,Top,Bot : DirPtr ;
Max,N,i,Tam : Byte;
Ch : Char ;
Sc : ScrPtr;
St : PathStr ;
CurSor,Att : Word ;
Na : NameStr;
E : ExtStr;
D : DirStr;
{-------------------------------------------------------}
Function RPad(St:String;N:Byte):String;
Begin
While Length(St) < N do St := St + #32 ;
RPad := St ;
End;
{-------------------------------------------------------}
Procedure GetPath(Var Path:PathStr);
Var F : File;
Begin
If Path[Length(Path)] = '\' then
Delete(Path,Length(Path),1);
Path := FExpand(Path);
Assign(F,Path);
GetFAttr(F,Att);
if (DosError = 0) and (Att and Directory 0)
and (Path[Length(Path)] '\') then
Path := Path + '\';
FSplit(Path, D, Na, E);
if Na = '' then Na := '*';
if E = '' then E := '.*';
Path := D + Na + E;
End;
{-------------------------------------------------------}
Procedure Appendlist(FileIf:SearchRec);
Begin
New(P);
P^.Name := FileIf.Name ;
p^.FileAttr := FileIf.Attr;
If First = Nil then
begin
First := P ;
First^.Pre := Nil
end
Else
begin
Last^.Next := P ;
P^.Pre := Last ;
end;
Last := P ;
Last^.Next := Nil
End;
{-------------------------------------------------------}
Procedure SortList;
Var P,Q : DirPtr; X:String[12];
Begin
P:= First;
While (PNil) and (PLast) do
Begin
Q:= P^.Next;
While ( QNil) do
Begin
If (P^.Name > Q^.Name) then
Begin
X:= P^.Name;
P^.Name:=Q^.Name;
Q^.Name:=X;
End;
Q:= Q^.Next;
end;
P:= P^.Next;
End;
End;
{-------------------------------------------------------}
Procedure FindFiles(Path:PathStr);
Var F: SearchRec;
Begin
FindFirst(Path,Archive+Directory,F);
While (DosError = 0) do
Begin
If (F.Attr and Directory > 0) and
(F.Name '.') then
F.Name :=F.Name+'\';
If F.Name '.' then Appendlist(F);
FindNext(F);
End;
End;
{-------------------------------------------------------}
Procedure WriteItem(P:DirPtr;N:Integer;Active:Boolean);
Var X,Y,Colo : Byte ;
Begin
If p nil then
Begin
If Active then Colo := IAttr
Else Colo := NAttr ;
X := 14*((N - 1) mod ColNum) + 2 + Col ;
Y := ((N - 1) div Colnum) + 1 + Row ;
WriteStr(x,y,Colo,RPad(P^.Name,12));
end;
End;
{-------------------------------------------------------}
Procedure DisplayTable(Var N : Byte );
Begin
N := 0;
Clear(col+1,Row+1,Col+14*ColNum,Row+RowNum,FrAttr);
P := Top ;
While (P Nil) and (N < ColNum*Rownum ) do
begin
inc(n);
WriteItem(P,N,False);
P := P^.Next ;
end;
If P=Nil then Bot := Last
Else Bot := P^.Pre;
End;
{-------------------------------------------------------}
Function GetItem : PathStr ;
Var i : Byte ;
Begin
First := Nil ;Last := Nil;
Mark(Heap);
GetPath(Path);
FindFiles(Path);
SortList;
Top := First ;
StrBox(Col,Row,Col+14*Colnum+1,Row+Rownum+1,
FrAttr,Double,Path,ShadeOn);
DisplayTable(Max);
P := Top ;
N:=1;
If First Nil then
Repeat
WriteItem(P,N,True);
Ch := Readkey ;
WriteItem(P,N,False);
If Ch = #0 then
Begin
Ch:= Readkey ;
Case Ch of
Up : If N - ColNum > 0 then
begin
For i := ColNum downto 1 do
p := p^.Pre;
Dec(N,ColNum);
end
Else
If (N = 1) and (TopFirst) then
begin
Top := Top^.Pre;
DisplayTable(Max);
P := Top;
end;
Down : If N + ColNum <= Max then
begin
For i := 1 to colnum do
Begin
p := P^.Next ;
Inc(N,1);
End;
end
Else
If (N=Max) and (PLast) then
begin
Top := Top^.Next;
DisPlayTable(Max);
P:=Top;
For i := 1 to Max-1 do
P:=P^.Next;
end;
Left : If N>1 then
Begin
P:=P^.Pre;
Dec(N);
End
Else
If (TopFirst) then
begin
Top := Top^.Pre;
DisplayTable(Max);
P := Top;
end;
Right: If N < Max then
Begin
P:=P^.Next;
Inc(N);
End
Else
If (PLast) then
begin
Top := Top^.Next;
DisPlayTable(Max);
P:=Top;
For i := 1 to Max-1 do
P:=P^.Next;
end;
Home : Begin
P:=Top;
N:=1;
End;
EndKey : Begin
P:=Bot;
N:=Max;
End;
PgUp : If Top First then
Begin
i:=0;
While (i<ColNum*RowNum) and
(Top^.PreNil) do
Begin
Inc(i);
Top:=Top^.Pre;
End;
DisplayTable(Max);
P:=Top;
If N>Max then N:=Max;
i:=1;
While i<N do
Begin
P:=P^.Next;
Inc(i);
End;
End;
PgDn : If Bot Last then
Begin
Top := Bot^.Next;
DisPlayTable(Max);
P:=Top;
If N>Max then N:=Max;
i:=1;
While i<N do
Begin
P:=P^.Next;
Inc(i);
End;
End;
End; { Case }
End; { If }
Until Ch in [Esc,Enter]
Else { First = Nil }
begin
WriteStr(col+2,row+1,NAttr,'File Not Found');
Repeat until keypressed;
end;
Release(Heap);
If P Nil then
GetItem:= P^.Name
else
GetItem := '';
End;
{=================== MenuDos =============================}
Begin
If Col = 0 then
Col := ((80-14*ColNum-2) div 2) + 1;
If Row = 0 then
Row := ((25-RowNum-2) div 2) + 1;
SaveScreen(Sc);
CurSor := GetCurSor;
CurSorOff;
Repeat
St := GetItem;
If (St[Length(St)]'\') then
FSplit(Path,D,Na,E);
Path := D+St;
Until Path[Length(Path)] '\';
If (Ch = Esc) or (St='') then
MenuDos := ''
Else { (Ch Esc) and (St'') }
MenuDos := Path;
RestoreScreen(Sc);
SetCurSor(CurSor);
End;
BEGIN
CSize := GetCurSor;
END.
Taäp tin nguoàn Thö vieän P_BAR
(P_BAR.PAS)
UNIT P_BAR ;
INTERFACE
Const
ShadeOn : Boolean = TRUE ;
ShadeOff : Boolean = FALSE ;
ShadeX : Byte = 2 ;
ShadeY : Byte = 1 ;
ShadeAtt : Byte = $07 ;
Null : Byte = 0 ;
Single : Byte = 1 ; Double : Byte = 2 ;
HorDouble : Byte = 3 ; VerDouble : Byte = 4 ;
ScrollDelay : Byte = 100 ;
TYPE
String30 = String[30];
ScreenType = Record
x1,y1,x2,y2 : Byte ;
Cx,Cy : Byte ;
Buf : Pointer ;
End;
ScreenPtr = ^ScreenType ;
ScrType = Array[1..25,1..80] of Word ;
ScrPtr = ^ScrType;
{$F+}
(*--------------------------------------------------------*)
Function RPad(St:String;N:Byte):String;
Function LPad(St:String;N:Byte):String;
Function LTrim(St:String):String;
Function RTrim(St:String):String;
Function UpStr(St:String):String;
Function LoStr(St:String):String;
Function Proper(St:String):String;
Function Bin(N:Byte):String;
Function Hex(W:Word):String;
Function Repl(Ch:Char;N:Byte):String;
Function GetKey:Word;
(*--------------------------------------------------------*)
Function GetChar(Col,Row:Byte):Word;
Procedure WriteChar(x,y,Attr,Len : Byte ; Ch :Char );
Procedure WriteStr(x,y,Attr :Byte ; St :String );
Procedure WriteColo(x,y,Att1,Att2:Byte;St:String);
Function NSt(N : Longint) : String ;
Procedure WriteInt(x,y,Att,Len:Byte;Int:Longint);
Function RSt(R : Real;N : Byte ) : String ;
Procedure WriteReal(x,y,Att,Len,Frac:Byte;R : Real);
Procedure ReadInt (x,y,Attr,L : Byte ; Var Lvar );
Procedure ReadWord (x,y,Attr,L : Byte ; Var Lvar );
Procedure ReadReal (x,y,Attr,L,N: Byte ; Var Rvar:Real );
Procedure ReadSt (x,y,Attr,L : Byte ; Var St);
Procedure CenterStr( y,StAttr :Byte;St : String);
Procedure BoxStr (x,y,BAttr,Lane,StAttr:Byte;St:String );
(*--------------------------------------------------------*)
Procedure DrawStr(SRow,Attr:Byte;St:string);
(*--------------------------------------------------------*)
Procedure SetAttr(x1,y1,x2,y2 , Attr :Byte );
(*--------------------------------------------------------*)
Procedure FillFrame(x1,y1,x2,y2,Attr:Byte;Ch:Char );
Procedure CLear(x1,y1,x2,y2,Attr:Byte );
Procedure Frame(x1,y1,x2,y2,Attr,Lane:Byte);
Procedure Box(x1,y1,x2,y2,Attr,Lane:Byte;Shade:Boolean);
Procedure FillBox(x1,y1,x2,y2,FrAttr,Lane:Byte;Ch:Char;Shade:Boolean);
Procedure StrBox(x1,y1,x2,y2,FrAttr,Lane : Byte ;St : String; Shade : Boolean);
Procedure StrLBox(x1,y1,x2,y2,FrAttr,Lane : Byte ;St : String; Shade :Boolean);
Procedure StrFillBox(x1,y1,x2,y2,FrAttr,Lane : Byte ; Ch:Char ; St :String;
Shade : Boolean);
(*--------------------------------------------------------*)
Procedure ScrollUp(x1,y1,x2,y2,Att,N:Byte);
Procedure ScrollDn(x1,y1,x2,y2,Att,N:Byte);
Procedure ScrollLf(x1,y1,x2,y2,Att,N:Byte);
Procedure ScrollRt(x1,y1,x2,y2,Att,N:Byte);
Procedure ShiftUp(x1,y1,x2,y2,Att:Byte);
Procedure ShiftDn(x1,y1,x2,y2,Att:Byte);
Procedure ShiftLf(x1,y1,x2,y2,Att:Byte);
Procedure ShiftRt(x1,y1,x2,y2,Att:Byte);
(*--------------------------------------------------------*)
Procedure SaveBox(x1,y1,x2,y2:Byte ; Var Bf : ScreenPtr);
Procedure RestoreBox(Var Bf : ScreenPtr);
Procedure DeInitBox(Var Bf : ScreenPtr);
Procedure SaveAtt(x1,y1,x2,y2:Byte ; Var Bf : ScreenPtr);
Procedure RestoreAtt(Var Bf : ScreenPtr);
Procedure DeInitAtt(Var Bf : ScreenPtr);
Procedure SaveScreen(Var Sc:ScrPtr);
Procedure RestoreScreen(Var Sc:ScrPtr);
(*--------------------------------------------------------*)
Function GETCURSOR : Word ;
Procedure SETCURSOR (Size : Word );
Procedure CURSOROFF ;
Procedure SMALLCURSOR ;
Procedure BIGCURSOR ;
(*--------------------------------------------------------*)
Function EGAInstalled : Boolean ;
Function PS2 : Boolean ;
{$F-}
{--------------------------------------------------------------}
IMPLEMENTATION
{--------------------------------------------------------------}
Uses Crt,Dos ;
{---------------------------------------}
Function RPad(St:String;N:Byte):String;
Begin
While Byte(St[0]) < N do St:=St+#32;
RPad:=St;
End;
{---------------------------------------}
Function LPad(St:String;N:Byte):String;
Begin
While Byte(St[0]) < N do St:=#32+St;
LPad:=St;
End;
{---------------------------------------}
Function LTrim(St:String):String;
Var i :Byte ;
Begin
i:=1;
While St[i]=#32 do Inc(i);
Delete(St,1,i-1);
LTrim:=St;
End;
{---------------------------------------}
Function RTrim(St:String):String;
Var i :Byte ;
Begin
i:=Byte(St[0]);
While St[i]=#32 do Dec(i);
Byte(St[0]):=i;
RTrim:=St;
End;
{---------------------------------------}
Function UpStr(St:String):String;
Var i :Byte ;
Begin
For i:= 1 to Byte(St[0]) do St[i]:=Upcase(St[i]);
UpStr:=St;
End;
{---------------------------------------}
Function LoStr(St:String):String;
Var i :Byte ;
Begin
For i:= 1 to Byte(St[0]) do
If (St[i]>='A') and (St[i]<='Z')then
Inc(St[i],32);
LoStr:=St;
End;
{---------------------------------------}
Function Proper(St:String):String;
Var i :Byte ;
Begin
St:= LoStr(LTrim(Rtrim(St)));
i:=Pos(#32#32,St);
While i0 do
Begin
Delete(St,i,1);
i:=Pos(#32#32,St);
End;
St[i]:=Upcase(St[i]);
For i := 2 to Byte(St[0])-1 do
If St[i]=#32 then St[i+1]:=UpCase(St[i+1]);
Proper:=St;
End;
{---------------------------------------}
Function GetKey:Word;
Var N : Word ;Ch:Char ;
Begin
N:= Ord(Readkey);
If N = 0 then
N:= (Word(Ord(Readkey)) Shl 8) + N ;
GetKey := N ;
End;
{---------------------------------------}
Function Bin(N:Byte):String;
Var Temp,Yst : String ;
Begin
Temp := '';
Repeat
Str(N Mod 2,YSt);
Temp := YSt+Temp;
N := N div 2 ;
Until N = 0 ;
While Length(Temp)<8 do Temp := '0'+Temp;
Bin := Temp;
End;
{---------------------------------------}
Function Hex(W:Word):String;
Var Temp,Yst : String ;
X : Byte ;
Begin
Temp := '';
Repeat
X := W mod 16 ;
If X < 10 then
Str(X,YSt)
Else
YSt := Chr(55+X);
Temp := YSt+Temp;
W := W div 16 ;
Until W = 0 ;
While Length(Temp)<4 do Temp := '0'+Temp;
Hex := '$'+Temp;
End;
{-------------------------------------------}
Function Repl(Ch:Char;N:Byte):String;
Var Temp : String;
Begin
Temp := '';
While Length(Temp) < N do Temp:= Temp+Ch;
Repl := Temp;
End;
{-------------------------------------------}
Function VIDSEG : Word ;
Begin
if MEM[$0:$0449] = 7 then
VidSeg := $B000
else
VidSeg := $B800 ;
End;
{-------------------------------------------}
Function Ofset(Col , Row : Byte ) : Word ;
Begin
case MEM[$0:$0449] of
0,1 : Ofset := 2*(Col-1) + 80*(Row-1) ;
else Ofset := 2*(Col-1) + 160*(Row-1) ;
end;
End;
{-------------------------------------------}
Function GetChar(Col,Row:Byte):Word;
Begin
GetChar := MemW[VidSeg:Ofset(Col,Row)]
End;
{-------------------------------------------}
Procedure WriteChar(x,y,Attr,Len : Byte ; Ch :Char );
Var
VSeg,VOfs : Word ;
i : Byte ;
Begin
VSeg := VidSeg ;
VOfs := Ofset(x,y) ;
For i := 1 to len do
Begin
MemW[VSeg:VOfs]:=(Attr Shl 8) + Ord(Ch);
VOfs := VOfs + 2 ;
End;
End;
{-------------------------------------------}
Procedure WriteStr(x,y,Attr :Byte ; St :String );
Var
VSeg,VOfs : Word ;
i : Byte ;
Begin
VSeg := VidSeg ;
VOfs := Ofset(x,y) ;
For i := 1 to length(St) do
Begin
MemW[VSeg:VOfs]:=(Attr Shl 8)+Ord(St[i]);
VOfs := VOfs + 2 ;
End;
End;
{-------------------------------------------}
Procedure WriteColo(x,y,Att1,Att2:Byte;St:String);
Var i,Att,Col : Byte ;
Begin
Att := Att2;Col := x ;
For i := 1 to Length(St) do
Begin
If St[i]='~' then
if att=att2 then
att := att1
else
att := att2
else
Begin
WriteChar(Col,y,Att,1,St[i]);
Inc(Col);
End;
End;
End;
{-------------------------------------------}
Function NSt(N : Longint) : String ;
Var Temp : String ;
I : Byte ;Am : Boolean ;
Begin
Am := N < 0 ;
If Am then N := - N ;
Str(N,Temp);
i := Length(Temp);
While i >= 4 do
Begin
Insert(',',Temp,i-2);
Dec(i,3);
End;
If Am then Nst := '-'+Temp
Else Nst := Temp ;
End;
{-------------------------------------------}
Procedure WriteInt(x,y,Att,Len:Byte;Int:Longint);
Var Temp : String;
Begin
Temp := NSt(Int);
While Length(Temp) < Len do Temp := #32 + Temp;
WriteStr(x,y,Att,Temp);
end;
{-------------------------------------------}
Function RSt(R : Real;N : Byte ) : String ;
Var Temp : String ;
I : Byte ;Am : Boolean ;
Begin
Am := R < 0 ;
If Am then R := - R ;
Str(R:N:N,Temp);
If N = 0 then
i:=Byte(Temp[0])
Else
i := Pos('.',Temp)-1;
While i >= 4 do
Begin
Insert(',',Temp,i-2);
Dec(i,3);
End;
If Am then Rst := '-'+Temp
Else Rst := Temp ;
End;
{-------------------------------------------}
Procedure WriteReal(x,y,Att,Len,Frac:Byte;R : Real);
Var Temp : String;
Begin
Temp := RSt(R,Frac);
While Length(Temp) < Len do Temp := #32 + Temp;
WriteStr(x,y,Att,Temp);
end;
{-------------------------------------------}
Procedure ReadInt (x,y,Attr,L : Byte ; Var Lvar );
Var Tempo : String ;
Result : Integer ;
Lmem : Longint absolute LVar ;
OAttr : Byte ;
Begin
OAttr := TextAttr ;
TextAttr := Attr ;
Repeat
Writechar(x,y,Attr,L,#32);
Gotoxy(x,y);Readln(Tempo);
Val(Tempo,Lmem,Result);
Until (Result = 0 );
WriteInt(x,y,Attr,L,LMem);
TextAttr := OAttr ;
End;
{-------------------------------------------}
Procedure ReadWord (x,y,Attr,L : Byte ; Var Lvar );
Var Tempo : String ;
Result : Integer ;
p,OAttr: Byte ;
Wmem : Word absolute LVar ;
Begin
OAttr := TextAttr ;
TextAttr := Attr ;
Repeat
Writechar(x,y,Attr,L,#32);
Gotoxy(x,y);Readln(Tempo);
Val(Tempo,Wmem,Result);
p := pos('-',tempo)
Until (Result = 0 ) and (p = 0);
WriteInt(x,y,Attr,L,Wmem);
TextAttr := OAttr ;
End;
{-------------------------------------------}
Procedure ReadReal (x,y,Attr,L,N: Byte ; Var Rvar:Real );
Var Tempo : String ;
Result : Integer ;
OAttr : Byte ;
Begin
OAttr := TextAttr ;
TextAttr := Attr ;
Repeat
Writechar(x,y,Attr,L,Chr(32));
Gotoxy(x,y);Readln(Tempo);
Val(tempo,RVar,Result);
Until Result = 0 ;
WriteReal(x,y,Attr,L,N,RVar);
TexTAttr := OAttr ;
End;
{-------------------------------------------}
Procedure ReadSt (x,y,Attr,L : Byte ; Var St);
Var
Str : String absolute St ;
Thoat : Boolean;
Ch: Char ;i,j:Byte;
Cot:Byte;
Begin
i:=1;Thoat:=False;
Writechar(x,y,Attr,L,Chr(32));
WriteStr(x,y,Attr,Copy(Str,1,L));
Repeat
Cot:=x+i-1;
GotoXy(Cot,y);
Ch:=ReadKey;
Case Ch Of
#32..#127:If i<=L then
Begin
Insert(Ch,Str,i);
Inc(i); If i>L Then i:=L;
End;
#13 :Thoat:=True;
#27 :Begin
Thoat:=True;
Str:='';
End;
#8 :Begin
Delete(Str,i-1,1);
Dec(i);
End;
#0 :Begin
Ch:=Readkey;
Case Ch of
#71 : i:=1;
#75 : If i>1 Then Dec(i);
#77 : If i<L Then
Begin
j:=Byte(Str[0]);
While Str[j]=#32 do Dec(j);
If i>j then
Insert(#32,Str,i);
Inc(i);
End;
#79 : Begin
i:=Byte(Str[0])+1;
While Str[i-1]=#32 do Dec(i);
If i>L then i:=L;
End;
#83 : Delete(Str,i,1);
End;
End;
End;
Writechar(x,y,Attr,L,Chr(32));
WriteStr(x,y,Attr,Copy(Str,1,L));
Until Thoat;
Str:=RTrim(Copy(Str,1,L));
End;
{-------------------------------------------}
Procedure CenterStr( y,StAttr :Byte;St : String);
Var x : Integer ;
Begin
x := ( 80 - Length(St) ) div 2 ;
WriteStr(x,y,StAttr,St);
End;
{-------------------------------------------}
Procedure BoxStr (x,y,BAttr,Lane,StAttr:Byte;St:String );
Begin
Box(x,y,x+Length(St)+3,y+2,BAttr,Lane,ShadeOff);
WriteStr(x+2,y+1,StAttr,St);
End;
{-------------------------------------------}
Procedure SetAttr(x1,y1,x2,y2 , Attr :Byte );
Var
VSeg,VOfs : Word ;
x,y : Byte ;
Begin
VSeg := VidSeg ;
For y := y1 to y2 do
For x:= x1 to x2 do
Begin
VOfs := Ofset(x,y) ;
Mem[VSeg:VOfs+1]:= Attr ;
End;
End;
{-------------------------------------------}
Procedure FillFrame(x1,y1,x2,y2,Attr:Byte;Ch:Char );
Var y : byte;
Begin
For y := y1 to y2 do
WriteChar(x1,y,Attr,x2-x1+1,Ch);
End;
{-------------------------------------------}
Procedure Clear(x1,y1,x2,y2,Attr:Byte );
Var y : byte;
Begin
For y := y1 to y2 do
WriteChar(x1,y,Attr,x2-x1+1,#32);
End;
{-------------------------------------------}
Procedure Box(x1,y1,x2,y2,Attr,Lane:Byte;Shade:Boolean);
Const Bound : Array[0..4] of String[6]
=(#32#32#32#32#32#32 ,#218#196#191#179#217#192,
#201#205#187#186#188#200,#213#205#184#179#190#212,
#214#196#183#186#189#211);
Var Border : String[6];
y : integer;
Begin
If Lane > 4 then Lane := 0 ;
Border := Bound[Lane];
If Shade then
SetAttr(x1+ShadeX,y1+ShadeY,
x2+ShadeX,y2+ShadeY,ShadeAtt);
WriteStr(x1,y1,Attr,Border[1]+Repl(Border[2],x2-x1-1)+
Border[3]);
For y := y1 + 1 to y2 -1 do
WriteStr(x1,y,Attr,Border[4]+Repl(#32,x2-x1-1)+
Border[4]);
WriteStr(x1,y2,Attr,Border[6]+Repl(Border[2],x2-x1-1)+
Border[5]);
End;
{-------------------------------------------}
Procedure Frame(x1,y1,x2,y2,Attr,Lane:Byte);
Const Bound : Array[0..4] of String[6]
=(#32#32#32#32#32#32 ,#218#196#191#179#217#192,
#201#205#187#186#188#200,#213#205#184#179#190#212,
#214#196#183#186#189#211);
Var Border : String[6];
y : integer;
Begin
If Lane > 4 then Lane := 0 ;
Border := Bound[Lane];
WriteStr(x1,y1,Attr,Border[1]+Repl(Border[2],x2-x1-1)+ Border[3]);
For y := y1 + 1 to y2 -1 do
Begin
WriteStr(x1,y,Attr,Border[4]);
WriteStr(x2,y,Attr,Border[4]);
End;
WriteStr(x1,y2,Attr,Border[6]+Repl(Border[2],x2-x1-1)+ Border[5]);
End;
{-------------------------------------------}
Procedure FillBox(x1,y1,x2,y2,FrAttr,Lane:Byte;Ch:Char;
Shade:Boolean);
Begin
Box(x1,y1,x2,y2,FrAttr,Lane,Shade);
FillFrame(x1+1,y1+1,x2-1,y2-1,FrAttr,Ch);
End;
{-------------------------------------------}
Procedure StrBox(x1,y1,x2,y2,FrAttr,Lane : Byte ;
St : String; Shade : Boolean);
Var x : Integer ;
Begin
BOX(x1,y1,x2,y2,FrAttr,Lane,Shade);
x := x1 + ((x2-x1-Length(St)-2) div 2);
WriteStr(x,y1,FrAttr,#32+St+#32);
End;
{-------------------------------------------}
Procedure StrLBox(x1,y1,x2,y2,FrAttr,Lane : Byte ;
St : String; Shade : Boolean);
Var x : Integer ;
Begin
BOX(x1,y1,x2,y2,FrAttr,Lane,Shade);
WriteStr(x1+3,y1,FrAttr,#32+St+#32);
End;
{-------------------------------------------}
Procedure StrFillBox(x1,y1,x2,y2,FrAttr,Lane : Byte ;
Ch:Char ; St : String;Shade : Boolean);
Var x : Integer ;
Begin
FILLBOX(x1,y1,x2,y2,FrAttr,Lane,Ch,Shade);
x := x1 + ((x2-x1-Length(St)-2) div 2);
WriteStr(x,y1,FrAttr,#32+St+#32);
End;
{-------------------------------------------}
Procedure DrawStr(SRow,Attr:Byte;St:string);
Type Charfont = Array[1..8] Of Byte;
Var CharTable : Array[0..255] of CharFont
Absolute $F000:$FA6E;
N,Len,SCol,CCol : Byte;
{---------------------------------------}
Procedure DrawChar(Entry:Charfont);
Var X,Y : Byte;
BinSt : String[8];
Begin
For Y := 1 to 8 do
Begin
BinSt := Bin(Entry [Y]);
For x := 1 to Length(BinSt) do
If BinSt[x]= '1' then
WriteStr(CCol+x,SRow+Y,Attr,#176);
End
End;
{------------------------------------------}
BEGIN
If SRow > 17 then SRow := 17;
St := Copy(St,1,10);
Len := Length(St);
SCol := (40 - 4*len) and $00FF;
For N := 1 to Len do
Begin
CCol := SCol + 8*( N - 1) + 1 ;
DrawChar(CharTable[Ord(St[N])]);
End;
End;
{------------------------------------------}
Procedure ScrollUp(x1,y1,x2,y2,Att,N:Byte);
Var y : Byte ;
Begin
For y := y1 to y2-n do
Move(Ptr(VidSeg,Ofset(x1,y+N))^,
Ptr(VidSeg,Ofset(x1,y) )^,2*(x2-x1+1));
Clear(x1,y2-N+1,x2,y2,Att);
End;
{------------------------------------------}
Procedure ScrollDn(x1,y1,x2,y2,Att,N:Byte);
Var y : Byte ;
Begin
For y := y2 Downto y1+n do
Move(Ptr(VidSeg,Ofset(x1,y-N))^,
Ptr(VidSeg,Ofset(x1,y) )^,2*(x2-x1+1));
Clear(x1,y1,x2,y1+N-1,Att);
End;
{------------------------------------------}
Procedure ScrollLf(x1,y1,x2,y2,Att,N:Byte);
Var y : Byte ;
Begin
For y := y1 to y2 do
Move(Ptr(VidSeg,Ofset(x1+N,y))^,
Ptr(VidSeg,Ofset(x1,y))^,2*(x2-x1-N+1));
Clear(x2-N,y1,x2,y2,Att);
End;
{------------------------------------------}
Procedure ScrollRt(x1,y1,x2,y2,Att,N:Byte);
Var y : Byte ;
Begin
For y := y1 to y2 do
Move(Ptr(VidSeg,Ofset(x1,y))^,
Ptr(VidSeg,Ofset(x1+N,y))^,2*(x2-x1-N+1));
Clear(x1,y1,x1+N-1,y2,Att);
End;
{-----------------------------------------}
Procedure ShiftUp(x1,y1,x2,y2,Att:Byte);
Var y : Byte ;
Begin
for y :=y1 to y2 do
Begin
ScrollUp(x1,y1,x2,y2,Att,1);
Delay(ScrollDelay);
end;
End;
{------------------------------------------}
Procedure ShiftDn(x1,y1,x2,y2,Att:Byte);
Var y : Byte ;
Begin
for y :=y1 to y2 do
Begin
ScrollDn(x1,y1,x2,y2,Att,1);
Delay(ScrollDelay);
end;
End;
{------------------------------------------}
Procedure ShiftLf(x1,y1,x2,y2,Att:Byte);
Var x : Byte ;
Begin
for x :=x1 to x2 do
Begin
ScrollLf(x1,y1,x2,y2,Att,1);
Delay(ScrollDelay);
end;
End;
{------------------------------------------}
Procedure ShiftRt(x1,y1,x2,y2,Att:Byte);
Var x : Byte ;
Begin
for x :=x1 to x2 do
Begin
ScrollRt(x1,y1,x2,y2,Att,1);
Delay(ScrollDelay);
end;
End;
{------------------------------------------}
Procedure SaveBox(x1,y1,x2,y2:Byte ; Var Bf : ScreenPtr);
Var NBytes,BSeg,BOfs : Word ;
y : Byte ;
Begin
NBytes := 2*(x2-x1+1);
New(Bf);
Bf^.x1 := x1; Bf^.y1:= y1;Bf^.x2 := x2; Bf^.y2:= y2;
Bf^.Cx := WhereX ; Bf^.Cy := WhereY ;
GetMem(Bf^.Buf,NBytes*(y2-y1+1));
BSeg := Seg(Bf^.Buf^);
BOfs := Ofs(Bf^.Buf^);
For y := y1 to y2 do
Begin
Move(Ptr(VidSeg,Ofset(x1,y))^,Ptr(BSeg,BOfs)^,
NBytes);
Inc(BOfs,NBytes);
end;
End;
{------------------------------------------}
Procedure RestoreBox(Var Bf : ScreenPtr);
Var NBytes,BSeg,BOfs : Word ;
y : Byte ;
Begin
With Bf^ do
Begin
NBytes := 2*(x2-x1+1);
BSeg := Seg(Buf^);
BOfs := Ofs(Buf^);
For y := y1 to y2 do
Begin
Move(Ptr(BSeg,BOfs)^,
Ptr(VidSeg,Ofset(x1,y))^,NBytes);
Inc(BOfs,NBytes);
end;
GotoXy(Cx,Cy);
{FreeMem(Buf,NBytes*(y2-y1+1));}
End;
DisPose(Bf);
End;
{------------------------------------------}
Procedure SaveAtt(x1,y1,x2,y2:Byte ; Var Bf : ScreenPtr);
Var NBytes,BSeg,BOfs : Word ;
y : Byte ;
Begin
NBytes := (x2-x1+1);
New(Bf);
Bf^.x1 := x1; Bf^.y1:= y1;Bf^.x2 := x2; Bf^.y2:= y2;
GetMem(Bf^.Buf,NBytes*(y2-y1+1));
BSeg := Seg(Bf^.Buf^);
BOfs := Ofs(Bf^.Buf^);
For y := y1 to y2 do
Begin
Move(Ptr(VidSeg,Ofset(x1,y)+1)^,Ptr(BSeg,BOfs)^,
NBytes);
Inc(BOfs,NBytes);
end;
End;
{------------------------------------------}
Procedure RestoreAtt(Var Bf : ScreenPtr);
Var NBytes,BSeg,BOfs : Word ;
x,y : Byte ;
Begin
With Bf^ do
Begin
NBytes := (x2-x1+1);
BSeg := Seg(Buf^);
BOfs := Ofs(Buf^);
For y := y1 to y2 do
Begin
For x := x1 to x2 do
Move(Ptr(BSeg,BOfs)^,
Ptr(VidSeg,Ofset(x,y)+1)^,1);
Inc(BOfs,NBytes);
end;
End;
End;
{------------------------------------------}
Procedure DeInitBox(Var Bf : ScreenPtr);
Begin
With Bf^ do
FreeMem(Buf,2*(x2-x1+1)*(y2-y1+1));
DisPose(Bf);
End;
{------------------------------------------}
Procedure DeInitAtt(Var Bf : ScreenPtr);
Begin
With Bf^ do
FreeMem(Buf,(x2-x1+1)*(y2-y1+1));
DisPose(Bf);
End;
{------------------------------------------}
Procedure SaveScreen(Var Sc : ScrPtr);
Var Mode : Byte Absolute $0:$0449;
Screen : ScrPtr;
Begin
If Mode = 7 then
Screen := Ptr($B000,$0000)
Else
Screen := Ptr($B800,$0000);
New(Sc);
SC^:=Screen^
End;
{------------------------------------------}
Procedure ReStoreScreen(Var Sc : ScrPtr);
Var Mode : Byte Absolute $0:$0449;
Screen : ScrPtr;
Begin
If Mode = 7 then
Screen := Ptr($B000,$0000)
Else
Screen := Ptr($B800,$0000);
Screen^:=Sc^;
Dispose(Sc);
End;
{------------------------------------------}
Function GetCurSor : Word ;
Var Regs : Registers ;
Begin
Regs.AH := $03;
Regs.BH := 0;
Intr($10,Regs);
GetCursor := Regs.CX ;
End;
{------------------------------------------}
Procedure SetCurSor (Size : Word );
Var Regs : Registers;
Begin
Regs.AH := 1;
Regs.CX := Size;
Intr(16,Regs);
End;
{------------------------------------------}
Procedure CursorOff ;
Begin
SetCursor($2020);
End;
{------------------------------------------}
Procedure SmallCurSor ;
Var Vmode : Byte Absolute $0:$0449;
Begin
If VMode = 7 then
SetCursor($0C0D)
else
SetCursor($0607);
End;
{------------------------------------------}
Procedure BigCurSor ;
Var Vmode : Byte Absolute $0:$0449 ;
Begin
If VMode = 7 then
SetCursor($000D)
else
SetCursor($0007);
End;
{------------------------------------------}
Function EGAInstalled : Boolean ;
{ Xaùc nhaän maøn hình EGA,VGA --> True }
{ CGA,MCGA -> False }
Var Regs : Registers ;
Begin
Regs.AX := $1200;
Regs.BX := $0010;
Regs.CX := $FFFF;
Intr($10,Regs);
EGAInstalled := Regs.CX $FFFF;
End;
{------------------------------------------}
Function PS2 : Boolean ;
{ Xaùc nhaän maøn hình VGA,MCGA --> True }
{ EGA,CGA --> False }
Var Regs : Registers ;
Begin
Regs.AX := $1A00;
Intr($10,Regs);
PS2 := ((Regs.AL and $FF) = $1A) and
((Regs.BL and $FF) in [$07,$08,$0B,$0C]);
End;
{--------------------------------------------------------------}
END.
Taäp tin nguoàn Thö vieän VIETFONT
(VIETFONT.PAS)
CONST
Font : Array [0..255,0..15] of Byte =
((0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
(0,0,126,129,129,165,129,129,129,165,153,129,129,126,0,0),
(0,0,126,255,255,255,219,255,255,219,231,255,255,126,0,0),
(0,0,0,0,108,238,254,254,254,124,124,56,16,0,0,0),
(0,0,0,0,16,56,56,124,254,124,56,56,16,0,0,0),
(0,0,0,24,60,60,24,231,231,231,24,24,60,0,0,0),
(0,0,0,24,24,60,126,126,255,255,102,24,126,0,0,0),
(0,0,0,0,0,0,24,60,60,24,0,0,0,0,0,0),
(255,255,255,255,255,255,231,195,195,231,255,255,255,255,255,255),
(0,0,0,0,0,60,102,66,66,102,60,0,0,0,0,0),
(255,255,255,255,255,195,153,189,189,153,195,255,255,255,255,255),
(0,0,0,0,30,14,26,50,120,204,204,204,120,0,0,0),
(0,0,0,0,60,102,102,102,60,24,126,24,24,0,0,0),
(0,0,0,0,63,51,63,48,48,48,112,240,224,0,0,0),
(0,0,0,0,127,99,127,99,99,99,103,231,230,192,0,0),
(0,0,0,0,24,219,90,60,231,60,90,219,24,0,0,0),
(0,0,0,0,128,192,224,248,254,248,224,192,128,0,0,0),
(0,0,0,0,2,6,14,62,254,62,14,6,2,0,0,0),
(0,0,0,0,24,60,126,24,24,24,126,60,24,0,0,0),
(0,0,0,0,102,102,102,102,102,102,0,102,102,0,0,0),
(0,0,0,0,127,219,219,219,123,27,27,27,27,0,0,0),
(0,0,0,124,198,96,56,108,198,108,56,12,198,124,0,0),
(0,0,0,0,0,0,0,0,0,0,254,254,254,0,0,0),
(0,0,0,0,24,60,126,24,24,24,126,60,24,126,0,0),
(0,0,0,0,24,60,126,24,24,24,24,24,24,0,0,0),
(0,0,0,0,24,24,24,24,24,24,126,60,24,0,0,0),
(0,0,0,0,0,0,24,12,254,12,24,0,0,0,0,0),
(0,0,0,0,0,0,48,96,254,96,48,0,0,0,0,0),
(0,0,0,0,0,0,0,192,192,192,254,0,0,0,0,0),
(0,0,0,0,0,0,36,102,255,102,36,0,0,0,0,0),
(0,0,0,0,0,16,56,56,124,124,254,254,0,0,0,0),
(0,0,0,0,0,254,254,124,124,56,56,16,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,24,60,60,60,24,24,0,24,24,0,0,0),
(0,0,0,102,102,102,36,0,0,0,0,0,0,0,0,0),
(0,0,0,0,108,108,254,108,108,108,254,108,108,0,0,0),
(0,0,24,24,124,198,194,192,124,6,134,198,124,24,24,0),
(0,0,0,0,0,0,194,198,12,24,48,102,198,0,0,0),
(0,0,0,0,56,108,108,56,118,220,204,204,118,0,0,0),
(0,0,0,48,48,48,96,0,0,0,0,0,0,0,0,0),
(0,0,0,0,12,24,48,48,48,48,48,24,12,0,0,0),
(0,0,0,0,48,24,12,12,12,12,12,24,48,0,0,0),
(0,0,0,0,0,0,102,60,255,60,102,0,0,0,0,0),
(0,0,0,0,0,0,24,24,126,24,24,0,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,24,24,24,48,0,0),
(0,0,0,0,0,0,0,0,254,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,24,24,0,0,0),
(0,0,0,0,2,6,12,24,48,96,192,128,0,0,0,0),
(0,0,0,0,124,198,206,222,246,230,198,198,124,0,0,0),
(0,0,0,0,24,56,120,24,24,24,24,24,126,0,0,0),
(0,0,0,0,124,198,6,12,24,48,96,198,254,0,0,0),
(0,0,0,0,124,198,6,6,60,6,6,198,124,0,0,0),
(0,0,0,0,12,28,60,108,204,254,12,12,30,0,0,0),
(0,0,0,0,254,192,192,192,252,6,6,198,124,0,0,0),
(0,0,0,0,60,96,192,192,252,198,198,198,124,0,0,0),
(0,0,0,0,254,198,6,12,24,48,48,48,48,0,0,0),
(0,0,0,0,124,198,198,198,124,198,198,198,124,0,0,0),
(0,0,0,0,124,198,198,198,126,6,6,12,120,0,0,0),
(0,0,0,0,0,24,24,0,0,0,24,24,0,0,0,0),
(0,0,0,0,0,24,24,0,0,0,24,24,48,0,0,0),
(0,0,0,0,6,12,24,48,96,48,24,12,6,0,0,0),
(0,0,0,0,0,0,0,126,0,0,126,0,0,0,0,0),
(0,0,0,0,96,48,24,12,6,12,24,48,96,0,0,0),
(0,0,0,0,124,198,198,12,24,24,0,24,24,0,0,0),
(0,0,0,0,124,198,198,222,222,222,220,192,124,0,0,0),
(0,0,0,0,16,56,108,198,198,254,198,198,198,0,0,0),
(0,0,0,0,252,102,102,102,124,102,102,102,252,0,0,0),
(0,0,0,0,60,102,194,192,192,192,194,102,60,0,0,0),
(0,0,0,0,248,108,102,102,102,102,102,108,248,0,0,0),
(0,0,0,0,254,102,98,104,120,104,98,102,254,0,0,0),
(0,0,0,0,254,102,98,104,120,104,96,96,240,0,0,0),
(0,0,0,0,60,102,194,192,192,222,198,102,58,0,0,0),
(0,0,0,0,198,198,198,198,254,198,198,198,198,0,0,0),
(0,0,0,0,60,24,24,24,24,24,24,24,60,0,0,0),
(0,0,0,0,30,12,12,12,12,12,204,204,120,0,0,0),
(0,0,0,0,230,102,108,108,120,108,108,102,230,0,0,0),
(0,0,0,0,240,96,96,96,96,96,98,102,254,0,0,0),
(0,0,0,0,198,238,254,254,214,198,198,198,198,0,0,0),
(0,0,0,0,198,230,246,254,222,206,198,198,198,0,0,0),
(0,0,0,0,56,108,198,198,198,198,198,108,56,0,0,0),
(0,0,0,0,252,102,102,102,124,96,96,96,240,0,0,0),
(0,0,0,0,124,198,198,198,198,214,222,124,12,14,0,0),
(0,0,0,0,252,102,102,102,124,108,102,102,231,0,0,0),
(0,0,0,0,124,198,198,96,56,12,198,198,124,0,0,0),
(0,0,0,0,126,126,90,24,24,24,24,24,60,0,0,0),
(0,0,0,0,198,198,198,198,198,198,198,198,124,0,0,0),
(0,0,0,0,198,198,198,198,198,198,108,56,16,0,0,0),
(0,0,0,0,198,198,198,198,214,214,254,124,108,0,0,0),
(0,0,0,0,198,198,108,56,56,56,108,198,198,0,0,0),
(0,0,0,0,102,102,102,102,60,24,24,24,60,0,0,0),
(0,0,0,0,254,198,140,24,48,96,194,198,254,0,0,0),
(0,0,0,0,60,48,48,48,48,48,48,48,60,0,0,0),
(0,0,0,0,128,192,224,112,56,28,14,6,2,0,0,0),
(0,0,0,0,60,12,12,12,12,12,12,12,60,0,0,0),
(0,0,16,56,108,198,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,0,0,0,0,0,255,0,0),
(0,0,48,48,24,0,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,120,12,124,204,204,118,0,0,0),
(0,0,0,0,224,96,96,120,108,102,102,102,124,0,0,0),
(0,0,0,0,0,0,0,124,198,192,192,198,124,0,0,0),
(0,0,0,0,28,12,12,60,108,204,204,204,118,0,0,0),
(0,0,0,0,0,0,0,124,198,254,192,198,124,0,0,0),
(0,0,0,0,56,108,100,96,240,96,96,96,240,0,0,0),
(0,0,0,0,0,0,0,118,204,204,204,124,12,204,120,0),
(0,0,0,0,224,96,96,108,118,102,102,102,230,0,0,0),
(0,0,0,0,24,24,0,56,24,24,24,24,60,0,0,0),
(0,0,0,0,6,6,0,14,6,6,6,6,102,102,60,0),
(0,0,0,0,224,96,96,102,108,120,108,102,230,0,0,0),
(0,0,0,0,56,24,24,24,24,24,24,24,60,0,0,0),
(0,0,0,0,0,0,0,236,254,214,214,214,198,0,0,0),
(0,0,0,0,0,0,0,220,102,102,102,102,102,0,0,0),
(0,0,0,0,0,0,0,124,198,198,198,198,124,0,0,0),
(0,0,0,0,0,0,0,220,102,102,102,124,96,96,240,0),
(0,0,0,0,0,0,0,118,204,204,204,124,12,12,30,0),
(0,0,0,0,0,0,0,220,118,102,96,96,240,0,0,0),
(0,0,0,0,0,0,0,124,198,112,28,198,124,0,0,0),
(0,0,0,0,16,48,48,252,48,48,48,54,28,0,0,0),
(0,0,0,0,0,0,0,204,204,204,204,204,118,0,0,0),
(0,0,0,0,0,0,0,102,102,102,102,60,24,0,0,0),
(0,0,0,0,0,0,0,198,198,214,214,254,108,0,0,0),
(0,0,0,0,0,0,0,198,108,56,56,108,198,0,0,0),
(0,0,0,0,0,0,0,198,198,198,198,126,6,12,248,0),
(0,0,0,0,0,0,0,254,204,24,48,102,254,0,0,0),
(0,0,0,0,14,24,24,24,112,24,24,24,14,0,0,0),
(0,0,0,0,24,24,24,24,0,24,24,24,24,0,0,0),
(0,0,0,0,112,24,24,24,14,24,24,24,112,0,0,0),
(0,0,0,0,118,220,0,0,0,0,0,0,0,0,0,0),
(0,0,0,0,0,0,16,56,108,198,198,254,0,0,0,0),
(0,0,0,0,0,0,124,198,192,192,198,124,24,12,248,0),
(0,0,0,0,204,204,0,204,204,204,204,204,118,0,0,0),
(0,0,0,0,108,108,0,120,12,124,204,204,118,0,0,0),
(0,0,48,72,72,48,0,120,12,124,204,204,118,0,0,0),
(0,0,0,0,108,108,0,124,198,254,192,198,124,0,0,0),
(0,0,0,0,108,108,0,56,24,24,24,24,60,0,0,0),
(0,0,0,24,60,102,0,56,24,24,24,24,60,0,0,0),
(0,0,0,0,108,222,26,26,126,216,216,218,108,0,0,0),
(0,0,0,0,204,204,0,124,198,198,198,198,124,0,0,0),
(0,0,0,48,120,204,0,204,204,204,204,204,118,0,0,0),
(0,0,0,0,198,198,0,198,198,198,198,126,6,12,120,0),
(0,0,24,24,24,124,198,192,192,198,124,24,24,24,0,0),
(0,0,0,56,108,100,96,240,96,96,102,230,188,0,0,0),
(0,0,0,102,102,102,60,24,126,24,60,24,24,0,0,0),
(0,0,0,252,102,102,124,98,102,111,102,102,243,0,0,0),
(0,0,0,0,118,220,0,220,102,102,102,102,102,0,0,0),
(0,0,0,0,0,0,54,108,216,108,54,0,0,0,0,0),
(0,0,0,0,0,0,216,108,54,108,216,0,0,0,0,0),
(0,0,0,0,24,24,24,126,24,24,24,0,126,126,0,0),
(0,0,0,0,96,48,24,12,24,48,96,0,124,124,0,0),
(0,0,0,0,12,24,48,96,48,24,12,0,124,124,0,0),
(24,24,24,60,60,126,126,255,24,24,24,24,24,24,24,24),
(24,24,24,24,24,24,24,24,255,126,126,60,60,24,24,24),
(0,0,0,0,0,64,112,124,255,124,112,64,0,0,0,0),
(0,0,0,0,0,2,14,62,255,62,14,2,0,0,0,0),
(0,0,108,56,0,56,108,198,198,254,198,198,198,0,0,0),
(0,16,56,108,0,56,108,198,198,254,198,198,198,0,0,0),
(0,16,56,68,254,102,98,104,120,104,98,102,254,0,0,0),
(0,16,56,68,56,108,198,198,198,198,198,108,56,0,0,0),
(0,0,3,1,58,108,198,198,198,198,198,108,56,0,0,0),
(0,0,3,1,199,198,198,198,198,198,198,198,124,0,0,0),
(0,0,0,0,248,108,102,102,254,102,102,108,248,0,0,0),
(0,0,0,0,108,56,0,120,12,124,204,204,118,0,0,0),
(0,0,0,0,56,108,0,120,12,124,204,204,118,0,0,0),
(0,0,0,0,56,108,0,124,198,254,192,198,124,0,0,0),
(0,0,0,0,56,108,0,124,198,198,198,198,124,0,0,0),
(0,0,0,0,0,3,1,126,198,198,198,198,124,0,0,0),
(0,0,0,0,0,3,1,206,204,204,204,204,118,0,0,0),
(0,0,0,0,12,62,12,60,108,204,204,204,118,0,0,0),
(0,0,192,96,48,0,0,120,12,124,204,204,118,0,0,0),
(0,0,56,8,16,0,0,120,12,124,204,204,118,0,0,0),
(0,0,0,118,220,0,0,120,12,124,204,204,118,0,0,0),
(0,0,6,12,24,0,0,120,12,124,204,204,118,0,0,0),
(0,0,0,0,0,0,0,120,12,124,204,204,118,0,48,48),
(0,0,96,16,76,56,0,120,12,124,204,204,118,0,0,0),
(0,0,7,1,110,56,0,120,12,124,204,204,118,0,0,0),
(0,0,118,220,108,56,0,120,12,124,204,204,118,0,0,0),
(0,0,12,16,108,56,0,120,12,124,204,204,118,0,0,0),
(68,17,68,17,68,17,68,17,68,17,68,17,68,17,68,17),
(170,85,170,85,170,85,170,85,170,85,170,85,170,85,170,85),
(119,221,119,221,119,221,119,221,119,221,119,221,119,221,119,221),
(24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24),
(24,24,24,24,24,24,24,24,248,24,24,24,24,24,24,24),
(0,0,0,0,108,56,0,120,12,124,204,204,118,0,48,48),
(0,0,192,96,56,108,0,120,12,124,204,204,118,0,0,0),
(0,0,7,1,58,108,0,120,12,124,204,204,118,0,0,0),
(0,0,118,220,56,108,0,120,12,124,204,204,118,0,0,0),
(54,54,54,54,54,54,54,246,6,246,54,54,54,54,54,54),
(54,54,54,54,54,54,54,54,54,54,54,54,54,54,54,54),
(0,0,0,0,0,0,0,254,6,246,54,54,54,54,54,54),
(54,54,54,54,54,54,54,246,6,254,0,0,0,0,0,0),
(0,0,6,12,56,108,0,120,12,124,204,204,118,0,0,0),
(0,0,0,0,56,108,0,120,12,124,204,204,118,0,48,48),
(0,0,0,0,0,0,0,0,248,24,24,24,24,24,24,24),
(24,24,24,24,24,24,24,24,31,0,0,0,0,0,0,0),
(24,24,24,24,24,24,24,24,255,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,255,24,24,24,24,24,24,24),
(24,24,24,24,24,24,24,24,31,24,24,24,24,24,24,24),
(0,0,0,0,0,0,0,0,255,0,0,0,0,0,0,0),
(24,24,24,24,24,24,24,24,255,24,24,24,24,24,24,24),
(0,0,192,96,48,0,0,124,198,254,192,198,124,0,0,0),
(0,0,56,8,16,0,0,124,198,254,192,198,124,0,0,0),
(54,54,54,54,54,54,54,55,48,63,0,0,0,0,0,0),
(0,0,0,0,0,0,0,63,48,55,54,54,54,54,54,54),
(54,54,54,54,54,54,54,247,0,255,0,0,0,0,0,0),
(0,0,0,0,0,0,0,255,0,247,54,54,54,54,54,54),
(54,54,54,54,54,54,54,55,48,55,54,54,54,54,54,54),
(0,0,0,0,0,0,0,255,0,255,0,0,0,0,0,0),
(54,54,54,54,54,54,54,247,0,247,54,54,54,54,54,54),
(0,0,0,118,220,0,0,124,198,254,192,198,124,0,0,0),
(0,0,6,12,24,0,0,124,198,254,192,198,124,0,0,0),
(0,0,0,0,0,0,0,124,198,254,192,198,124,0,24,24),
(0,0,192,96,56,108,0,124,198,254,192,198,124,0,0,0),
(0,0,7,1,58,108,0,124,198,254,192,198,124,0,0,0),
(0,0,118,220,56,108,0,124,198,254,192,198,124,0,0,0),
(0,0,6,12,56,108,0,124,198,254,192,198,124,0,0,0),
(0,0,0,0,56,108,0,124,198,254,192,198,124,0,24,24),
(0,0,192,96,48,0,0,56,24,24,24,24,60,0,0,0),
(0,0,56,8,16,0,0,56,24,24,24,24,60,0,0,0),
(24,24,24,24,24,24,24,24,248,0,0,0,0,0,0,0),
(0,0,0,0,0,0,0,0,31,24,24,24,24,24,24,24),
(255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255),
(0,0,0,118,220,0,0,56,24,24,24,24,60,0,0,0),
(0,0,6,12,24,0,0,56,24,24,24,24,60,0,0,0),
(0,0,0,0,24,24,0,56,24,24,24,24,60,0,24,24),
(0,0,192,96,48,0,0,124,198,198,198,198,124,0,0,0),
(0,0,0,0,62,96,192,192,254,192,192,96,62,0,0,0),
(0,0,56,8,16,0,0,124,198,198,198,198,124,0,0,0),
(0,0,118,220,0,0,0,124,198,198,198,198,124,0,0,0),
(0,0,6,12,24,0,0,124,198,198,198,198,124,0,0,0),
(0,0,0,0,0,0,0,124,198,198,198,198,124,0,24,24),
(0,0,192,96,56,108,0,124,198,198,198,198,124,0,0,0),
(0,0,7,1,58,108,0,124,198,198,198,198,124,0,0,0),
(0,0,118,220,56,108,0,124,198,198,198,198,124,0,0,0),
(0,0,6,12,56,108,0,124,198,198,198,198,124,0,0,0),
(0,0,0,0,56,108,0,124,198,198,198,198,124,0,24,24),
(0,0,192,96,48,3,1,126,198,198,198,198,124,0,0,0),
(0,0,56,8,16,3,1,126,198,198,198,198,124,0,0,0),
(0,0,118,220,0,3,1,126,198,198,198,198,124,0,0,0),
(0,0,6,12,24,3,1,126,198,198,198,198,124,0,0,0),
(0,0,0,0,0,3,1,126,198,198,198,198,124,0,24,24),
(0,0,192,96,48,0,0,204,204,204,204,204,118,0,0,0),
(0,0,0,0,0,254,0,0,254,0,0,254,0,0,0,0),
(0,0,56,8,16,0,0,204,204,204,204,204,118,0,0,0),
(0,0,118,220,0,0,0,204,204,204,204,204,118,0,0,0),
(0,0,6,12,24,0,0,204,204,204,204,204,118,0,0,0),
(0,0,0,0,0,0,0,204,204,204,204,204,118,0,48,48),
(0,0,192,96,48,3,1,206,204,204,204,204,118,0,0,0),
(0,0,56,8,16,3,1,206,204,204,204,204,118,0,0,0),
(0,0,118,220,0,3,1,206,204,204,204,204,118,0,0,0),
(0,0,6,12,24,3,1,206,204,204,204,204,118,0,0,0),
(0,0,0,0,0,3,1,206,204,204,204,204,118,0,48,48),
(0,0,192,96,48,0,0,198,198,198,198,126,6,12,248,0),
(0,0,56,8,16,0,0,198,198,198,198,126,6,12,248,0),
(0,0,0,118,220,0,0,198,198,198,198,126,6,12,248,0),
(0,0,6,12,24,0,0,198,198,198,198,126,6,12,248,0),
(0,0,0,0,0,0,0,198,198,198,198,126,4,12,251,3),
(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0));
Thö vieän naøy khi kích hoaït seõ chieám moät phaàn boä nhôù vaø naïp Font tieáng Vieät vaøo boä Font chuaån cuûa maùy. Coù nghóa laø ta coù theå söû duïng, hieån thò tieáng Vieät trong chöông trình chính.
Các file đính kèm theo tài liệu này:
LUANVAN.DOC- BIA.DOC
- COMMON.DOC
