xprocs.pas

详细说明:毕业论文中关于小型宾馆管理系统的详细设计毕 业论文中关于小型宾馆...一个酒店管理系统VB+Access [学生学籍管理系统(VB+Acess).zip] - !这个是刚刚编的毕业设计,可能

function  sysTempPath:String;
procedure sysDelay(aMs: Longint);
procedure sysBeep;
function  sysColorDepth: Integer;    { 06.08.96 sb }

{$IFDEF Win32}
procedure sysSaverRunning(Active: Boolean);
{$ENDIF}

{ registry functions }

{$IFDEF Win32}
function  regReadString(aKey: hKey; const Path: String): String;
procedure regWriteString(aKey: hKey; const Path,Value: String);
procedure regDelValue(aKey: hKey; const Path: String);
function  regInfoString(const Value: String): String;
function  regCurrentUser: String;
function  regCurrentCompany: String;
procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);

{ The following five functions came from David W. Yutzy / Celeste Software Services
  Thanks for submitting us the methods !!
}
procedure regKeyList(aKey: HKEY; const Path:String; var aValue: TStringList);
function  regValueExist(aKey: HKEY; const Path:String):Boolean;
function  regWriteValue(aKey: HKEY; const Path: String; Value: Variant; Typ: TDataType): Boolean;
function  regReadValue(aKey:HKEY; const Path:String; Typ: TDataType): Variant;
procedure regValueList(aKey: HKEY; const Path:String; var aValue: TStringList);
{$ENDIF}

{ several functions }
function  Question(const Msg: String):Boolean;
procedure Information(const Msg: String);
function  Confirmation(const Msg: String): Word;

type
  { TRect that can be used persistent as property for components }
  TUnitConvertEvent = function (Sender: TObject;
    Value: Integer; Get: Boolean): Integer of object;

  TPersistentRect = class(TPersistent)
  private
    FRect      : TRect;
    FOnConvert : TUnitConvertEvent;
    procedure SetLeft(Value: Integer);
    procedure SetTop(Value: Integer);
    procedure SetHeight(Value: Integer);
    procedure SetWidth(Value: Integer);
    function  GetLeft: Integer;
    function  GetTop: Integer;
    function  GetHeight: Integer;
    function  GetWidth: Integer;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    property Rect: TRect read FRect;
    property OnConvert: TUnitConvertEvent read FOnConvert write FOnConvert;
  published
    property Left  : Integer read GetLeft   write SetLeft;
    property Top   : Integer read GetTop    write SetTop;
    property Height: Integer read GetHeight write SetHeight;
    property Width : Integer read GetWidth  write SetWidth;
  end;

{$IFDEF Win32}
  { Persistent access of components from the registry }
  TPersistentRegistry = class(TRegistry)
  public
    function  ReadComponent(const Name: String; Owner, Parent: TComponent): TComponent;
    procedure WriteComponent(const Name: String; Component: TComponent);
  end;
{$ENDIF

  { easy access of the system metrics }
  TSystemMetric = class
  private
    FColorDepth,
    FMenuHeight,
    FCaptionHeight : Integer;
    FBorder,
    FFrame,
    FDlgFrame,
    FBitmap,
    FHScroll,
    FVScroll,
    FThumb,
    FFullScreen,
    FMin,
    FMinTrack,
    FCursor,
    FIcon,
    FDoubleClick,
    FIconSpacing : TPoint;
  protected
    constructor Create;
    procedure Update;
  public
    property MenuHeight: Integer read FMenuHeight;
    property CaptionHeight: Integer read FCaptionHeight;
    property Border: TPoint read FBorder;
    property Frame: TPoint read FFrame;
    property DlgFrame: TPoint read FDlgFrame;
    property Bitmap: TPoint read FBitmap;
    property HScroll: TPoint read FHScroll;
    property VScroll: TPoint read FVScroll;
    property Thumb: TPoint read FThumb;
    property FullScreen: TPoint read FFullScreen;
    property Min: TPoint read FMin;
    property MinTrack: TPoint read FMinTrack;
    property Cursor: TPoint read FCursor;
    property Icon: TPoint read FIcon;
    property DoubleClick: TPoint read FDoubleClick;
    property IconSpacing: TPoint read FIconSpacing;
    property ColorDepth: Integer read FColorDepth;
  end;

var
  SysMetric: TSystemMetric;

type
  TDesktopCanvas = class(TCanvas)
  private
    DC           : hDC;
  public
    constructor  Create;
    destructor   Destroy; override;
  end;

implementation

uses
  SysUtils, Controls, Forms, Consts, Dialogs;

{ bit manipulating }
function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
begin
  Result:= (Value and (1 shl TheBit)) <> 0;
end;

function bitOn(const Value: Int_; const TheBit: TBit): Int_;
begin
  Result := Value or (1 shl TheBit);
end;

function bitOff(const Value: Int_; const TheBit: TBit): Int_;
begin
  Result := Value and ((1 shl TheBit) xor $FFFFFFFF);
end;

function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
begin
  result := Value xor (1 shl TheBit);
end;

{ string methods }

function strHash(const S: String; LastBucket: Integer): Integer;
var
  i: Integer;
begin
  Result:=0;
  for i := 1 to Length(S) do
    Result := ((Result shl 3) xor Ord(S[i])) mod LastBucket;
end;

function strTrim(const S: String): String;
begin
  Result:=StrTrimChR(StrTrimChL(S,BLANK),BLANK);
end;

function strTrimA(const S: String): String;
begin
  Result:=StrTrimChA(S,BLANK);
end;

function strTrimChA(const S: String; C: Char): String;
var
  I               : Word;
begin
  Result:=S;
  for I:=Length(Result) downto 1 do
    if Result[I]=C then Delete(Result,I,1);
end;

function strTrimChL(const S: String; C: Char): String;
begin
  Result:=S;
  while (Length(Result)>0) and (Result[1]=C) do Delete(Result,1,1);
end;

function strTrimChR(const S: String; C: Char): String;
begin
  Result:=S;
  while (Length(Result)> 0) and (Result[Length(Result)]=C) do
    Delete(Result,Length(Result),1);
end;

function strLeft(const S: String; Len: Integer): String;
begin
  Result:=Copy(S,1,Len);
end;

function strLower(const S: String): String;
begin
  Result:=AnsiLowerCase(S);
end;

function strMake(C: Char; Len: Integer): String;
begin
  Result:=strPadChL('',C,Len);
end;

function strPadChL(const S: String; C: Char; Len: Integer): String;
begin
  Result:=S;
  while Length(Result)<Len do Result:=C+Result;
end;

function strPadChR(const S: String; C: Char; Len: Integer): String;
begin
  Result:=S;
  while Length(Result)<Len do Result:=Result+C;
end;

function strPadChC(const S: String; C: Char; Len: Integer): String;
begin
  Result:=S;
  while Length(Result)<Len do
  begin
    Result:=Result+C;
    if Length(Result)<Len then Result:=C+Result;
  end;
end;

function strPadL(const S: String; Len: Integer): String;
begin
  Result:=strPadChL(S,BLANK,Len);
end;

function strPadC(const S: String; Len: Integer): String;
begin
  Result:=strPadChC(S,BLANK,Len);
end;


function strPadR(const S: String; Len: Integer): String;
begin
  Result:=strPadChR(S,BLANK,Len);
end;

function strPadZeroL(const S: String; Len: Integer): String;
begin
  Result:=strPadChL(strTrim(S),ZERO,Len);
end;

function strCut(const S: String; Len: Integer): String;
begin
  Result:=strLeft(strPadR(S,Len),Len);
end;

function strRight(const S: String; Len: Integer): String;
begin
  if Len>=Length(S) then
    Result:=S
  else
    Result:=Copy(S,Succ(Length(S))-Len,Len);
end;

function strAddSlash(const S: String): String;
begin
  Result:=S;
  if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
end;

function strDelSlash(const S: String): String;
begin
  Result:=S;
  if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
end;

function strSpace(Len: Integer): String;
begin
  Result:=StrMake(BLANK,Len);
end;

function strToken(var S: String; Seperator: Char): String;
var
  I               : Word;
begin
  I:=Pos(Seperator,S);
  if I<>0 then
  begin
    Result:=System.Copy(S,1,I-1);
    System.Delete(S,1,I);
  end else
  begin
    Result:=S;
    S:='';
  end;
end;

function strTokenCount(S: String; Seperator: Char): Integer;
begin
  Result:=0;
  while S<>'' do begin            { 29.10.96 sb }
    StrToken(S,Seperator);
    Inc(Result);
  end;
end;

function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
var
  j,i: Integer;
begin
  Result:='';
  j := 1;
  i := 0;
  while (i<=At ) and (j<=Length(S)) do
  begin
    if S[j]=Seperator then
       Inc(i)
    else if i = At then
       Result:=Result+S[j];
    Inc(j);
  end;
end;

procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
var
  Token: String;
begin
  List.Clear;
  Token:=strToken(S,Seperator);
  while Token<>'' do
  begin
    List.Add(Token);
    Token:=strToken(S,Seperator);
  end;
end;

function strTokenFromStrings(Seperator: Char; List: TStrings): String;
var
  i: Integer;
begin
  Result:='';
  for i:=0 to List.Count-1 do
     if Result<>'' then
       Result:=Result+Seperator+List[i]
     else
       Result:=List[i];
end;

function strUpper(const S: String): String;
begin
  Result:=AnsiUpperCase(S);
end;

function strOemAnsi(const S:String):String;
begin
 {$IFDEF Win32}
  SetLength(Result,Length(S));
 {$ELSE}
  Result[0]:=Chr(Length(S));
 {$ENDIF}
  OemToAnsiBuff(@S[1],@Result[1],Length(S));