xprocs.pas

很久以前用delphi写的一个SQLServer外部的企业管理器

unit xProcs;

{$D-}

interface

{.$DEFINE German}
{.$DEFINE English}

uses
 {$IFDEF Win32} Windows, Registry, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  ShellAPI, Messages, Classes, Graphics;

type
  Float = Extended;    { our type for float arithmetic }

 {$IFDEF Win32}        { our type for integer functions, Int_ is ever 32 bit }
  Int_  = Integer;
 {$ELSE}
  Int_  = Longint;
 {$ENDIF}

const
  XCOMPANY        = 'Fabula Software';

const
  { several important ASCII codes }
  NULL            =  #0;
  BACKSPACE       =  #8;
  TAB             =  #9;
  LF              = #10;
  CR              = #13;
  EOF_            = #26;    { 30.07.96 sb }
  ESC             = #27;
  BLANK           = #32;
  SPACE           = BLANK;

  { digits as chars }
  ZERO   = '0';  ONE  = '1';  TWO    = '2';  THREE  = '3';  FOUR  = '4';
  FIVE   = '5';  SIX  = '6';  SEVEN  = '7';  EIGHT  = '8';  NINE  = '9';

  { special codes }
  SLASH           = '\';     { used in filenames }
	HEX_PREFIX      = '$';     { prefix for hexnumbers }

  CRLF            : PChar = CR+LF;

  { common computer sizes }
  KBYTE           = Sizeof(Byte) shl 10;
  MBYTE           = KBYTE        shl 10;
  GBYTE           = MBYTE        shl 10;

  { Low floating point value }
  FLTZERO         : Float = 0.00000001;

  DIGITS          : set of Char = [ZERO..NINE];

  { important registry keys / items }
  REG_CURRENT_VERSION = 'Software\Microsoft\Windows\CurrentVersion';
  REG_CURRENT_USER    = 'RegisteredOwner';
  REG_CURRENT_COMPANY = 'RegisteredOrganization';

  PRIME_16       = 65521;
  PRIME_32       = 2147483647;

  MINSHORTINT    = -128;               { 1.8.96 sb }
  MAXSHORTINT    =  127;
  MINBYTE        =  0;
	MAXBYTE        =  255;
  MINWORD        =  0;
  MAXWORD        =  65535;

type
  TMonth        = (NoneMonth,January,February,March,April,May,June,July,
                   August,September,October,November,December);

  TDayOfWeek    = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);

  { Online eMail Service Provider }
  TMailProvider = (mpCServe, mpInternet, mpNone);

  TLicCallback  = function ( var Code: Integer): Integer;

  TBit          = 0..31;

  { Search and Replace options }
  TSROption     = (srWord,srCase,srAll);
  TSROptions    = set of TsrOption;

  { Data types }
  TDataType     = (dtInteger,dtBoolean,dtString,dtDate,dtTime,
                   dtFloat,dtCurrency);

var
  IsWin95,
  IsWinNT   : Boolean;
  IsFabula  : TLicCallBack;

  xLanguage : Integer;
  xLangOfs  : Integer;

{ bit manipulating }
function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
function bitOn(const Value: Int_; const TheBit: TBit): Int_;
function bitOff(const Value: Int_; const TheBit: TBit): Int_;
function bitToggle(const Value: Int_; const TheBit: TBit): Int_;

{ String functions }
function  strHash(const S: String; LastBucket: Integer): Integer;
function  strCut(const S: String; Len: Integer): String;
function  strTrim(const S: String): String;
function  strTrimA(const S: String): String;
function  strTrimChA(const S: String; C: Char): String;
function  strTrimChL(const S: String; C: Char): String;
function  strTrimChR(const S: String; C: Char): String;
function  strLeft(const S: String; Len: Integer): String;
function  strLower(const S: String): String;
function  strMake(C: Char; Len: Integer): String;
function  strPadChL(const S: String; C: Char; Len: Integer): String;
function  strPadChR(const S: String; C: Char; Len: Integer): String;
function  strPadChC(const S: String; C: Char; Len: Integer): String;
function  strPadL(const S: String; Len: Integer): String;
function  strPadR(const S: String; Len: Integer): String;
function  strPadC(const S: String; Len: Integer): String;
function  strPadZeroL(const S: String; Len: Integer): String;
function  strPos(const aSubstr,S: String; aOfs: Integer): Integer;
procedure strChange(var S:String; const Src, Dest: String);
function  strChangeU(const S,Source, Dest: String): String;
function  strRight(const S: String; Len: Integer): String;
function  strAddSlash(const S: String): String;
function  strDelSlash(const S: String): String;
function  strSpace(Len: Integer): String;
function  strToken(var S: String; Seperator: Char): String;
function  strTokenCount(S: String; Seperator: Char): Integer;
function  strTokenAt(const S:String; Seperator: Char; At: Integer): String;
procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
function  strTokenFromStrings(Seperator: Char; List: TStrings): String;

function  strUpper(const S: String): String;
function  strOemAnsi(const S:String): String;
function  strAnsiOem(const S:String): String;
function  strEqual(const S1,S2: String): Boolean;
function  strComp(const S1,S2: String): Boolean;
function  strCompU(const S1,S2: String): Boolean;
function  strContains(const S1,S2: String): Boolean;
function  strContainsU(const S1,S2: String): Boolean;
function  strNiceNum(const S: String): String;
function  strNiceDateDefault(const S, Default: String): String;
function  strNiceDate(const S: String): String;
function  strNiceTime(const S: String): String;
function  strNicePhone(const S: String): String;
function  strReplace(const S: String; C: Char; const Replace: String): String;
function  strCmdLine: String;
function  strEncrypt(const S: String; Key: Word): String;
function  strDecrypt(const S: String; Key: Word): String;
function  strLastCh(const S: String): Char;
procedure strStripLast(var S: String);
function  strByteSize(Value: Longint): String;
function  strSoundex(S: String): String;
procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
function  strCapitalize(const S: String): String;  { 31.07.96 sb }

{$IFDEF Win32}
procedure strDebug(const S: String);
function  strFileLoad(const aFile: String): String;
procedure strFileSave(const aFile,aString: String);
{$ENDIF}

{ Integer functions }
function  intCenter(a,b: Int_): Int_;
function  intMax(a,b: Int_): Int_;
function  intMin(a,b: Int_): Int_;
function  intPow(Base,Expo: Integer): Int_;
function  intPow10(Exponent: Integer): Int_;
function  intSign(a: Int_): Integer;
function  intZero(a: Int_; Len: Integer): String;
function  intPrime(Value: Integer): Boolean;
function  intPercent(a, b: Int_): Int_;

{ Floatingpoint functions }
function  fltAdd(P1,P2: Float; Decimals: Integer): Float;
function  fltDiv(P1,P2: Float; Decimals: Integer): Float;
function  fltEqual(P1,P2: Float; Decimals: Integer): Boolean;
function  fltEqualZero(P: Float): Boolean;
function  fltGreaterZero(P: Float): Boolean;
function  fltLessZero(P: Float): Boolean;
function  fltNeg(P: Float; Negate: Boolean): Float;
function  fltMul(P1,P2: Float; Decimals: Integer): Float;
function  fltRound(P: Float; Decimals: Integer): Float;
function  fltSub(P1,P2: Float; Decimals: Integer): Float;
function  fltUnEqualZero(P: Float): Boolean;
function  fltCalc(const Expr: String): Float;
function  fltPower(a,n: Float): Float;
function  fltPositiv(Value: Float): Float;
function  fltNegativ(Value: Float): Float;

{ Rectangle functions from Golden Software }
function  rectHeight(const R: TRect): Integer;
function  rectWidth(const R: TRect): Integer;
procedure rectGrow(var R: TRect; Delta: Integer);
procedure rectRelativeMove(var R: TRect; DX, DY: Integer);
procedure rectMoveTo(var R: TRect; X, Y: Integer);
function  rectSet(Left, Top, Right, Bottom: Integer): TRect;
function  rectInclude(const R1, R2: TRect): Boolean;
function  rectPoint(const R: TRect; P: TPoint): Boolean;
function  rectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
function  rectIntersection(const R1, R2: TRect): TRect;
function  rectIsIntersection(const R1, R2: TRect): Boolean;
function  rectIsValid(const R: TRect): Boolean;
function  rectsAreValid(const Arr: array of TRect): Boolean;
function  rectNull: TRect;
function  rectIsNull(const R: TRect): Boolean;
function  rectIsSquare(const R: TRect): Boolean;
function  rectCentralPoint(const R: TRect): TPoint;
function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;

{$IFDEF Win32}
{ Variant functions }
function  varIIF( aTest: Boolean; TrueValue, FalseValue : Variant): Variant;
procedure varDebug(const V: Variant);
function  varToStr(const V: Variant): String;
{$ENDIF}

{ date functions }
function  dateYear(D: TDateTime): Integer;
function  dateMonth(D: TDateTime): Integer;
function  dateDay(D: TDateTime): Integer;
function  dateBeginOfYear(D: TDateTime): TDateTime;
function  dateEndOfYear(D: TDateTime): TDateTime;
function  dateBeginOfMonth(D: TDateTime): TDateTime;
function  dateEndOfMonth(D: TDateTime): TDateTime;
function  dateWeekOfYear(D: TDateTime): Integer;
function  dateDayOfYear(D: TDateTime): Integer;
function  dateDayOfWeek(D: TDateTime): TDayOfWeek;
function  dateLeapYear(D: TDateTime): Boolean;
function  dateBeginOfQuarter(D: TDateTime): TDateTime;
function  dateEndOfQuarter(D: TDateTime): TDateTime;
function  dateBeginOfWeek(D: TDateTime;Weekday: Integer): TDateTime;
function  dateDaysInMonth(D: TDateTime): Integer;
function  dateQuicken(D: TDateTime; var Key: Char): TDateTime;
{function  dateDiff(D1,D2: TDateTime): Integer;}

{ time functions }
function  timeHour(T: TDateTime): Integer;
function  timeMin(T: TDateTime): Integer;
function  timeSec(T: TDateTime): Integer;
function  timeToInt(T: TDateTime): Integer;

{$IFDEF Win32}
function  timeZoneOffset: Integer;
{$ENDIF}

{ com Functions }
function  comIsCis(const S: String): Boolean;
function  comIsInt(const S: String): Boolean;
function  comCisToInt(const S: String): String;
function  comIntToCis(const S: String): String;
function  comFaxToCis(const S: String): String;
function  comNormFax(const Name,Fax: String): String;
function  comNormPhone(const Phone: String): String;
function  comNormInt(const Name,Int: String): String;
function  comNormCis(const Name,Cis: String): String;

{ file functions }
procedure fileShredder(const Filename: String);
function  fileSize(const Filename: String): Longint;
function  fileWildcard(const Filename: String): Boolean;
function  fileShellOpen(const aFile: String): Boolean;
function  fileShellPrint(const aFile: String): Boolean;
function  fileCopy(const SourceFile, TargetFile: String): Boolean;

{$IFDEF Win32}
function  fileTemp(const aExt: String): String;
function  fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
function  fileRedirectExec(const aCmdLine: String; Strings: TStrings): Boolean;
function  fileLongName(const aFile: String): String;
function  fileShortName(const aFile: String): String;
function  fileTypeName(const aFile: String): String;
{$ENDIF}
function  ExtractName(const Filename: String): String;

{ system functions }
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;