dutils.pas

delphi usb源代码,但版本比较旧。需要Dos.pas 和,crt.pas

{ DUTILS - Turbo Pascal UTILITIES                      }
{ (c) 1994 by Dieter Pawelczak                         }

{$R-}
{$D+}
{$S-}
unit DUTILS;
interface
uses DOS,crt;
const { Month names and number of days - used to display the date }
  MonthStr: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun','Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  DayStr: Array[0..6] of String[3] = ('Su.','Mo.','Tu.','We.','Th.','Fr.','Sa.');
  MonatStr: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun','Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez');
  TagStr: Array[0..6] of String[3] = ('So.','Mo.','Di.','Mi.','Do.','Fr.','Sa.');
  MonthLen: Array[1..12] of Byte=(31,28,31,30,31,30,31,31,30,31,30,31);

var
  Path: PathStr;
  scrtyp:Word;


(*    File - Procedures                             *)

procedure copyfile(Source,Dest:String);
function Filelength(pth:string):LongInt;
procedure IsExt(VAR Filename:String;Ext:String);
FUNCTION GetExefilesize(Exename:String): LONGINT;
function getprgdir(prg:string):String;(* read directory of prg file      *)
function fileexist(fn:String):Boolean;

(*    CRT routines                                  *)

procedure cursoroff;
procedure cursoron;

procedure color(ccl,cch:Byte);        (* color (Fore -,background)       *)
function Bigletters(bl:String):String;(* German upcase                   *)


Procedure Twin(x1,y1,x2,y2:Byte);
Procedure Twin2(x1,y1,x2,y2:Byte);  (* Double          *)
Procedure Twin1(x1,y1,x2,y2:Byte);  (* Single          *)
Procedure Cwin2(x1,y1,x2,y2,attr:Byte);  (* Double with colour attributes     *)
Procedure Cwin1(x1,y1,x2,y2,attr:Byte);  (* single                            *)
Procedure tback;                    (* draw background                        *)
procedure shad(xx,yy:WORD);
procedure print(x1,y1:word;t:string);(* print with no attributes *)
procedure cprint(x1,y1:word;t:string;attr:byte);(* print with attributes *)

(* Number Conversions                               *)

procedure twodecout(xx:real);
procedure hexout(xx:word);          (* print hex number                   *)
function bins16(xx:word):String;
function bins8(xx:byte):String;
function bins(xx:longint):String;
 function hexs(xx:longint):String;
function hexs8(xx:byte):String;
function hexs16(xx:word):String;
function twodecs(xx:real):String;   (* convert real to string             *)
function decs(xx:longint;format:Byte):String;(* convert integer to String *)
function hextodec(s:string):longint;(* convert Hex to Longint             *)

(* Date and Time                                    *)

function getweekday(d,m,y:word):integer; (* d-day m-month y-year          *)
function date(typ:boolean):String;  (* convert date to string             *)
procedure stime;                      (* show time                       *)
function time:String;               (* get time               HH.MM.SS    *)
function timeexact:String;          (* get time               HH.MM.SS.hh *)

(* Keyboard  *)

function shiftpressed:Boolean;
function strpressed:Boolean;
function Altpressed:Boolean;
function altgrpressed:Boolean;




implementation


function shiftpressed:Boolean;
var std:byte;
begin
asm
  mov ah,2;
  int 16h
  mov std,al
  end;
shiftpressed:=(std and 1=1)or(std and 2=2);
end;

function strpressed:Boolean;
var std:byte;
begin
asm
  mov ah,2;
  int 16h
  mov std,al
  end;
strpressed:=(std and 4=4);
end;

function Altpressed:Boolean;
var std:byte;
begin
asm
  mov ah,2;
  int 16h
  mov std,al
  end;
Altpressed:=(std and 8=8);
end;

function altgrpressed:Boolean;
var std:byte;
begin
asm
  mov ah,12h;
  int 16h
  mov std,ah
  end;
altgrpressed:=(std and 8=8);
end;





function getweekday(d,m,y:word):integer;
var h1,s:longint;
    ii:Byte;
    iss:boolean;

begin
iss:=false;
if y mod 4=0 then iss:=true;
if y mod 100=0 then if (y mod 400<>0) then iss:=false;
s:=0;if y>1 then s:=(y-1) div 4-(y div 100)+(y div 400);
h1:=y+s;
if m>1 then for ii:=1 to m-1 do h1:=h1+longint(Monthlen[ii]);
if m>2 then if iss then h1:=h1+1;
h1:=h1+d;
getweekday:=h1 mod 7;
end;

function date(Typ:Boolean):String;
VAR yy,mm,dd,dw:WORD;
    TG:String;
begin
getdate(yy,mm,dd,dw);
if not typ then tg:=TagStr[dw] else tg:=daystr[dw];
date:=tg+', '+decs(dd,2)+'.'+decs(mm,2)+'.'+decs(yy,4);
end;

function time:String;
VAR hh,mm,ss,dw:WORD;
    TG,TI:String;
begin
gettime(hh,mm,ss,dw);
ti:=decs(mm,2);if ti[1]=' ' then ti[1]:='0';
tg:=decs(hh,2)+'.'+ti;
ti:=decs(ss,2);if ti[1]=' ' then ti[1]:='0';
tg:=tg+'.'+ti;time:=tg;
end;

function timeexact:String;
VAR hh,mm,ss,dw:WORD;
    TG,TI:String;
begin
gettime(hh,mm,ss,dw);
ti:=decs(mm,2);if ti[1]=' ' then ti[1]:='0';
tg:=decs(hh,2)+'.'+ti;
ti:=decs(ss,2);if ti[1]=' ' then ti[1]:='0';
tg:=tg+'.'+ti;
ti:=decs(dw,2);if ti[1]=' ' then ti[1]:='0';
tg:=tg+'.'+ti;timeexact:=tg;
end;

{$I-}
function fileexist(fn:String):Boolean;
var ff:text;
   i:integer;
begin
i:=ioresult;
Assign(ff,fn);reset(ff);
if ioresult=0 then
  begin close(ff); fileexist:=true end else fileexist:=false;


end;

function single(s:char):longint;
var i:longint;
begin
if ord(s)>58 then i:=ord(s)-55 else i:=ord(s)-48;
single:=i;
end;

function hextodec(s:string):longint;
var i:longint;
begin
s:=bigletters(s);
if pos('$',s)=1 then s:=copy(s,2,length(s)-1);
while s[length(s)]=' ' do s:=copy(s,1,length(s)-1);
i:=0;
while length(s)<>0
do
begin
if length(s)=5 then i:=i+65536*single(s[1]);
if length(s)=4 then i:=i+4096*single(s[1]);
if length(s)=3 then i:=i+256*single(s[1]);
if length(s)=2 then i:=i+16*single(s[1]);
if length(s)=1 then i:=i+single(s[1]);
s:=copy(s,2,length(s)-1);
end;
hextodec:=i;
end;

procedure cprint(x1,y1:word;t:string;attr:byte);
var h2,h3:WORD;
begin
t:=t+#0;
h2:=ofs(t)+1;
h3:=seg(t);
      asm
      push ds
      push es
      push si
      push di
      mov ax,h3
      mov es,ax
      mov ax,y1
      dec ax
      mov dx,$00A0
      mul dx
      mov bx,ax
      mov ax,x1
      dec ax
      shl ax,1
      add ax,bx
      mov di,ax
      mov si,h2
      mov ax,ScrTyp;
      mov ds,ax;
      mov bh,attr
@002:
      mov bl,es:[si]
      cmp bl,0
      je @003
      moV ds:[di],bx
      inc di
      inc di
      inc si
      jmp @002
@003:
      pop di
      pop si
      pop es
      pop ds
      end;
end;
procedure print(x1,y1:word;t:string);
var h2,h3:WORD;
begin
t:=t+#0;
h2:=ofs(t)+1;
h3:=seg(t);
      asm
      push ds
      push es
      push si
      push di
      mov ax,h3
      mov es,ax
      mov ax,y1
      dec ax
      mov dx,$00A0
      mul dx
      mov bx,ax
      mov ax,x1
      dec ax
      shl ax,1
      add ax,bx
      mov di,ax
      mov si,h2
      mov ax,ScrTyp;
      mov ds,ax;
@002:
      mov bl,es:[si]
      cmp bl,0
      je @003
      moV ds:[di],bl
      inc di
      inc di
      inc si
      jmp @002
@003:
      pop di
      pop si
      pop es
      pop ds
      end;
end;

procedure color(ccl,cch:Byte);
begin
textcolor(ccl);TextBackground(cch);
end;

function NumStr(N, D: Integer): String;
begin
  NumStr[0] := Chr(D);
  while D > 0 do
  begin
    NumStr[D] := Chr(N mod 10 + Ord('0'));
    N := N div 10;
    Dec(D);
  end;
end;

function getprgdir(prg:string):String;
var nam:Namestr;
    ext:Extstr;
    pth:pathstr;
    umg:dirstr;
    s:string;
begin
  s:=FSEARCH(prg,'*.*');
  if s='' then s:=FSearch(prg,getenv('PATH'));
  pth:=s;
  Fsplit(pth,umg,nam,ext);
  getprgdir:=umg;
end;

procedure IsExt(VAR Filename:String;Ext:String);
begin
if pos('.',Filename)=0 then Filename:=Filename+Ext;
end;

function Filelength(pth:string):LongInt;
var i:longint;
    fi:file;
begin
{$I-}
assign(fi,pth);reset(fi,1);i:=0;
IF IOResult=0 then i:=FileSize(fi);
{$I+}
close(fi);
Filelength:=i;
end;



procedure stime;
var
hour,min,sec,sec100:word;
z:string[3];
zeit:string[10];

begin
  gettime(hour,min,sec,sec100);
        zeit:='';
        str(hour,z);if hour<10 then z:='0'+z;
        zeit:=z+':';
        str(min,z);if min<10 then z:='0'+z;
        zeit:=zeit+z+':';
        str(sec,z);if sec<10 then z:='0'+z;
        zeit:='<'+zeit+z+'>';
        print(70,25,zeit);
end;
function Bigletters(bl:String):String;
var i:Byte;
begin
for i:=1 to length(bl) do
begin
if (bl[i]>='a') and (bl[i]<='z') then bl[i]:=CHR(ord(bl[i])-32);
if bl[i]='