funcsex.pas

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

//
// This unit provides miscellaneous utility functions for general use.
//
unit funcsEx;

interface

uses
  SysUtils, Classes, Windows, DB, nb30, Forms, Registry, ActiveX, ComObj,
  Controls, StdCtrls, ComCtrls, shlobj, Graphics, DBGrids, Dialogs;


const    C1 = 52845;                   // For Encrypt/Decrypt functions
         C2 = 22719;                   // If these values are changed, then
         ENC_KEY = 35095;              // existing encrypted strings in the
                                       // registry cannot be decrypted
//
// DCOM settings not defined in Delphi
//
const
  RPC_C_AUTHN_LEVEL_DEFAULT       = 0;
  RPC_C_AUTHN_LEVEL_NONE          = 1;
  RPC_C_AUTHN_LEVEL_CONNECT       = 2;
  RPC_C_AUTHN_LEVEL_CALL          = 3;
  RPC_C_AUTHN_LEVEL_PKT           = 4;
  RPC_C_AUTHN_LEVEL_PKT_INTEGRITY = 5;
  RPC_C_AUTHN_LEVEL_PKT_PRIVACY   = 6;

  RPC_C_IMP_LEVEL_ANONYMOUS   = 1;
  RPC_C_IMP_LEVEL_IDENTIFY    = 2;
  RPC_C_IMP_LEVEL_IMPERSONATE = 3;
  RPC_C_IMP_LEVEL_DELEGATE    = 4;

  EOAC_NONE = $0000;

//
// See DCOM_Register
//
type
  TRegType = (rtAxLib, rtTypeLib, rtExeLib);
  TRegProc = function : HResult; stdcall;
  TUnRegTlbProc = function (const libID: TGUID; wVerMajor, wVerMinor: Word;
    lcid: TLCID; syskind: TSysKind): HResult; stdcall;
  TRegAction = (raReg, raUnreg);

//
// See DCOM_Register
//
const
  ProcName: array[TRegAction] of PChar = (
    'DllRegisterServer', 'DllUnregisterServer');
  ExeFlags: array[TRegAction] of string = (' /regserver', ' /unregserver');

// Network functions
function ChooseComputer(parent_window: HWND; caption: String): String;
function ChooseShare(parent_window: HWND; caption: String): String;
function NetworkBrowsing(parent_window: HWND; caption: String; browse_for: Integer): String;

// Date & time functions
function UTCNow: TDateTime;
function UTCDate: TDateTime;
function UTCTime: TDateTime;
function UTC2Local(utc_time: TDateTime): TDateTime;
function Local2UTC(local_time: TDateTime): TDateTime;
function UTC2LocalStr(utc_date: TDate; utc_time: TTime): String;
function TimeZone: String;

// Encryption & string functions
function SecurityCode(clear_text: String): String;
function SecurityCodeValid(clear_text, security_code: String): Boolean;
function Encrypt(const S: String; encryption_key: Integer=ENC_KEY): String;
function Decrypt(const S: String; decryption_key: Integer=ENC_KEY): String;
function UnprintableRandomString(len: Integer): WideString;
function PrintableRandomString(len: Integer): String;

// File functions
function VariantToFile(thefile: OleVariant; fname:string; append_to: Boolean=FALSE): boolean;
function FileToVariant(fname:string): OleVariant;
procedure EmptyDirectory(dir: string);

// DCOM functions
function DCOM_Register(filename: String): Integer;


// System functions
function GetWorkArea: TRect;
function IsNT : bool;
function WinExecAndWait32(FileName:String; Visibility:integer=SW_SHOWDEFAULT):integer;
function WinExec32(FileName:String; Visibility:integer=SW_SHOWDEFAULT):integer;

// Misc. functions
procedure EnableHints(Sender: TControl);
procedure BringToTheFront(value: TForm);
procedure EmptyControls(value: TWinControl);
procedure ColourControls(value: TWinControl; opt_colour, mand_colour, sys_colour: TColor);



procedure EmptyDir(dir:string);
// Find relevant FieldCount by FieldName for Administration, Manager, Configuration workshop.
function FindField(GridName: TDBGrid; const FieldName: String): Integer;
function RunExe(filename:string):boolean;
procedure sysDelay(aMs: Longint);

//============================================================================

implementation

//
// Display a dialog box allowing the user to choose a computer (not a drive,
// printer, etc. but just a computer in the network).
//
// Args: parent window (usually TForm.Handle)
//       caption to display on the dialog box,  e.g. Choose Cache Server
//
// Returns: computer chosen
//          empty string on error or no computer chosen
//
function ChooseComputer(parent_window: HWND; caption: String): String;
begin
     Result:=NetworkBrowsing(parent_window, caption, BIF_BROWSEFORCOMPUTER);
end;

//
// Display a dialog box allowing the user to choose a share on a network
//
// Args: parent window (usually TForm.Handle)
//       caption to display on the dialog box, e.g. Choose share
//
// Returns: share chosen
//          empty string on error or no share chosen
//
function ChooseShare(parent_window: HWND; caption: String): String;
begin
     Result:=NetworkBrowsing(parent_window, caption, BIF_RETURNONLYFSDIRS);
end;

//
// Display a dialog box allowing the user to choose a computer, network drive,
// etc.
//
// Args: parent window (usually TForm.Handle)
//       caption to display on the dialog box, e.g. Choose Cache Server
//       what to browse for (e.g. BIF_BROWSEFORCOMPUTER for computers)
//
// Returns: computer chosen
//          empty string on error or no computer chosen
//
// Note: typical browse_for values are
//
//   BIF_RETURNONLYFSDIRS for networked folders
//   BIF_BROWSEFORCOMPUTER for computers
//
function NetworkBrowsing(parent_window: HWND; caption: String; browse_for: Integer): String;
var lpbi: _browseInfo;
    dn: String;
    idlist: ITEMIDLIST;
    ridlist: PITEMIDLIST;
    ppMalloc: IMalloc;
begin
     try
        // Get pointer to network root
        SHGetSpecialFolderLocation(parent_window, CSIDL_NETWORK, PITEMIDLIST(idlist));

        // Initialise & display dialog box
        lpbi.hwndOwner:=parent_window;
        lpbi.pidlRoot:=PITEMIDLIST(idlist);
        SetLength(dn, 255);
        lpbi.pszDisplayName:=PChar(dn);
        lpbi.lpszTitle:=PChar(caption);
        lpbi.ulFlags:=browse_for;
        lpbi.lpfn:=nil;
        ridlist:=SHBrowseForFolder(lpbi);

        // Store the resuls
{xxx
        if browse_for <> BIF_BROWSEFORCOMPUTER then begin
           // Return the complete network path
           SetLength(Result, 255);
           SHGetPathFromIDList(ridlist, PChar(Result));
        end else
}
           // Return only the name of the 'thing' selected
           Result:=lpbi.pszDisplayName;

        // Free memory
        if ridlist=nil then
           Result:=''
        else begin
           SHGetMalloc(ppMalloc);
           ppMalloc.Free(ridlist);
        end;
     except
        // Oops
        Result:='';
     end;
end;

//
// Enable all the hints on a form or control etc. which have hint text
//
// Args: control to enable hints on
//
// Note: also enables hints on child controls
//
procedure EnableHints(Sender: TControl);
var i: Integer;
begin
     try
        if Sender.Hint<>'' then Sender.ShowHint:=TRUE
        else if (Sender is TLabel) then begin
             (Sender as TLabel).Hint:=(Sender as TLabel).FocusControl.Hint;
             if Sender.Hint<>'' then Sender.ShowHint:=TRUE
        end;
     except
        // Ignore
     end;

     try
        if (Sender is TWinControl) then begin
           for i:=0 to (Sender as TWinControl).ControlCount - 1 do begin
               if (Sender as TWinControl).Controls[i].Hint<>'' then
                  (Sender as TWinControl).Controls[i].ShowHint:=TRUE;
               EnableHints((Sender as TWinControl).Controls[i]);
           end;
        end;
     except
        // Ignore
     end;
end;

//
// Create a security code from a clear-text string
//
// Args: clear-text string (used with SecurityCodeValid at a later time)
//
// Returns: security code
//          empty string on error
//
// xxx this needs beefing up!
//
const SECURITY_CODE_PREFIX='_SC_';
function SecurityCode(clear_text: String): String;
begin
     Result:=Encrypt(SECURITY_CODE_PREFIX+clear_text, 31423);
end;

//
// Check if a supplied security code is valid
//
// Args: clear-text string
//       security code (produced by SecurityCode function)
//
// Returns: TRUE if valid
//
function SecurityCodeValid(clear_text, security_code: String): Boolean;
var orig: String;
begin
     orig:=Decrypt(security_code, 31423);
     if orig<>SECURITY_CODE_PREFIX+clear_text then Result:=FALSE else Result:=TRUE;
end;

//
// Bring a window to the front of the display
//
// Args: form to bring to the front
//
procedure BringToTheFront(value: TForm);
begin
     if not value.Visible then value.Visible:=TRUE;
     value.BringToFront;
     Application.BringToFront;
     SetForegroundWindow(value.Handle);
end;

//
// This function empties a control (and all its child controls) of their values
// e.g. edit fields are cleared, combo-boxes are reset so nothing is selected
// Modification values are set to FALSE where appropriate
//
// Args: control (and its children) to clear
//
procedure EmptyControls(value: TWinControl);
var i: Integer;
begin
     // Clear this control
     if (value is TEdit) then begin
        (value as TEdit).Clear;
        (value as TEdit).Modified:=FALSE;
     end else if (value is TComboBox) then begin
        (value as TComboBox).ItemIndex:= -1;
     end else if (value is TCheckBox) then begin
        (value as TCheckBox).Checked:=FALSE;
     end else if (value is TDateTimePicker) then begin
        (value as TDateTimePicker).DateTime:=Now;
     end;

     // Clear its child controls
     for i:=0 to value.ControlCount - 1 do
         if (value.Controls[i] is TWinControl) then
            EmptyControls((value.Controls[i] as TWinControl));
end;

//
// This function changes the colours of a control (and all its child controls)
// to the correct system defined colours
//
// Args: control (and its children) to correctly colour
//
// NOTE: The colours must already be set on the form:
//
//       clAqua=system
//       clYellow=mandatory
//       clWindow=optional
//
procedure ColourControls(value: TWinControl; opt_colour, mand_colour, sys_colour: TColor);
var i: Integer;
begin
     // Colour this control
     if (value is TEdit) then begin
        if (value as TEdit).Color=clAqua then (value as TEdit).Color:=sys_colour
        else if (value as TEdit).Color=clWindow then (value as TEdit).Color:=opt_colour
        else if (value as TEdit).Color=clYellow then (value as TEdit).Color:=mand_colour;
     end else if (value is TComboBox) then begin
        if (value as TComboBox).Color=clAqua then (value as TComboBox).Color:=sys_colour
        else if (value as TComboBox).Color=clWindow then (value as TComboBox).Color:=opt_colour
        else if (value as TComboBox).Color=clYellow then (value as TComboBox).Color:=mand_colour;
     end else if (value is TCheckBox) then begin
        if (value as TCheckBox).Color=clAqua then (value as TCheckBox).Color:=sys_colour
        else if (value as TCheckBox).Color=clWindow then (value as TCheckBox).Color:=opt_colour
        else if (value as TCheckBox).Color=clYellow then (value as TCheckBox).Color:=mand_colour;
     end else if (value is TDateTimePicker) then begin
        if (value as TDateTimePicker).Color=clAqua then (value as TDateTimePicker).Color:=sys_colour
        else if (value as TDateTimePicker).Color=clWindow then (value as TDateTimePicker).Color:=opt_colour
        else if (value as TDateTimePicker).Color=clYellow then (value as TDateTimePicker).Color:=mand_colour;
     end;

     // Colour its child controls
     for i:=0 to value.ControlCount - 1 do
         if (value.Controls[i] is TWinControl) then
            ColourControls((value.Controls[i] as TWinControl), opt_colour, mand_colour, sys_colour);
end;

//
// Return the current time zone, e.g. Singapore Standard Time
//
function TimeZone: String;
var TimeZoneInfo: TTimeZoneInformation;
    r: DWORD;
begin
     r:=GetTimeZoneInformation(TimeZoneInfo);
     if r=TIME_ZONE_ID_STANDARD then Result:=TimeZoneInfo.StandardName
     else if r=TIME_ZONE_ID_DAYLIGHT then Result:=TimeZoneInfo.DaylightName
     else Result:='';
end;

//
// Converts a UTC time & date to the local time & date
//
// Args: UTC time to convert
//
// Returns: local time