vgsystem.pas

大家是不是为不知道如何在VB学到绝地程序

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff Delphi VCL Library         }
{         Special system classes                        }
{                                                       }
{         Copyright (c) 1997, 2000                      }
{                                                       }
{         TPropInfoList, TPropsFiler (TPropsStorage)    }
{         Copyright (c) 1995, 1997 RX Library           }
{                                                       }
{*******************************************************}

{$I VG.INC }
{$D-,L-}

unit vgSystem;

interface
uses Windows, SysUtils, TypInfo, Classes, IniFiles{$IFDEF _D3_}, ActiveX{$ENDIF};

type
{$IFNDEF _D4_}
  PLongWord = ^LongWord;
  LongWord = Longint;

  POleVariant = ^OleVariant;
  {$IFNDEF _D3_}
  OleVariant = Variant;
  {$ENDIF}

  TSysCharSet = set of Char;
{$ENDIF}

  TCharSet = TSysCharSet;

  TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;

  TDayTable = array[1..12] of Word;
  PDayTable = ^TDayTable;

  PIntArray = ^TIntArray;
  TIntArray = array[0..0] of Integer;

  PVariantArray = ^TVariantArray;
  TVariantArray = array[0..0] of Variant;

  TMaxPath = array[0..MAX_PATH - 1] of Char;

  PInstance = ^HINST;

const
  MaxDispArgs = 32;

type
  PNamesArray = ^TNamesArray;
  TNamesArray = array[0..MaxDispArgs - 1] of PWideChar;
  TNames      = array [0..1023] of Char;

  PDispIDs    = ^TDispIDs;
  TDispID     = Longint;
  TDispIDs    = array [0..MaxDispArgs - 1] of TDispID;

  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
    ExceptionRecord: PExceptionRecord;
  end;

{ TTlsBuffer }
  TTlsBuffer = class
  private
    FBlocks: TList;
    FSize: Integer;
    FTlsIndex: Integer;
    function GetMemory: Pointer;
    function GetTlsValue: Pointer;
    class procedure AddTlsBuffer(ATlsBuffer: TTlsBuffer);
    class procedure RemoveTlsBuffer(ATlsBuffer: TTlsBuffer);
  protected
    function AllocMemory(ASize: Integer): Pointer; virtual;
    procedure DoDetachThreadInternal;
    procedure FreeMemory(P: Pointer); virtual;
  public
    constructor Create(ASize: Integer);
    destructor Destroy; override;
    class procedure DoDetachThread;
    property Memory: Pointer read GetMemory;
    property Size: Integer read FSize;
    property TlsIndex: Integer read FTlsIndex;
  end;

{ TCustomThread }
  TCustomThread = class(TThread)
  protected
    procedure DoExecute; virtual;
    procedure DoHandleException(Sender: TObject); virtual;
    procedure Execute; override;
  end;

{ TCustomWaitThread }
  TCustomWaitThread = class(TCustomThread)
  private
    FEvent: THandle;
    FTimeout: DWord;
  protected
    procedure DoReset; virtual;
    procedure DoTimeout; virtual;
    procedure DoExecute; override;
  public
    constructor Create(CreateSuspended: Boolean; ATimeout: DWord);
    destructor Destroy; override;
    procedure Reset(TerminateThread: Boolean);
    property Timeout: DWord read FTimeout write FTimeout;
  end;

{ TWaitThread }
  TWaitThread = class(TCustomWaitThread)
  private
    FOnReset, FOnTimeout: TNotifyEvent;
  protected
    procedure DoReset; override;
    procedure DoTimeout; override;
  public
    property OnReset: TNotifyEvent read FOnReset write FOnReset;
    property OnTimeout: TNotifyEvent read FOnTimeout write FOnTimeout;
  end;

{ TThreadEx }
  TThreadEx = class(TCustomThread)
  private
    FOnExecute, FOnException: TNotifyEvent;
  protected
    procedure DoExecute; override;
    procedure DoHandleException(Sender: TObject); override;
  public
    property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;
    property OnException: TNotifyEvent read FOnException write FOnException;
  end;

{ TCustomMessageThread }
  TCustomMessageThread = class(TCustomThread)
  protected
    procedure DoAfterMessage(const Msg: TMsg; const RetValue: Integer); virtual;
    procedure DoBeforeMessage(var Msg: TMsg; var Handled: Boolean); virtual;
    procedure DoExecute; override;
  public
    destructor Destroy; override;
    procedure PostMessage(Msg: UINT; wParam: WPARAM; lParam: LPARAM);
    procedure PostQuitMessage;
    procedure WaitForQuit;
  end;

{ TMessageThread }
  TAfterMessageEvent = procedure (const  Msg: TMsg; const RetValue: Integer) of object;
  TBeforeMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;

  TMessageThread = class(TCustomMessageThread)
  private
    FOnAfterMessage: TAfterMessageEvent;
    FOnBeforeMessage: TBeforeMessageEvent;
  protected
    procedure DoAfterMessage(const Msg: TMsg; const RetValue: Integer); override;
    procedure DoBeforeMessage(var Msg: TMsg; var Handled: Boolean); override;
  public
    property OnAfterMessage: TAfterMessageEvent read FOnAfterMessage write FOnAfterMessage;
    property OnBeforeMessage: TBeforeMessageEvent read FOnBeforeMessage write FOnBeforeMessage;
  end;

{ TPropInfoList }
  TPropInfoList = class(TObject)
  private
    FList: PPropList;
    FCount: Integer;
    FSize: Integer;
    function Get(Index: Integer): PPropInfo;
  public
    constructor Create(AObject: TObject; Filter: TTypeKinds);
    destructor Destroy; override;
    function Find(const AName: string): PPropInfo;
    procedure Delete(Index: Integer);
    property Count: Integer read FCount;
    property Items[Index: Integer]: PPropInfo read Get; default;
  end;

{$IFNDEF _D4_}
  TCustomIniFile = TIniFile;
{$ENDIF}

{$IFDEF _D4_}
{ TPropsFiler }
  TPropsFiler = class(TObject)
  private
    FIniFile: TCustomIniFile;
    FObject: TObject;
    FOwner: TComponent;
    FPrefix: string;
    FSection: string;
    function StoreIntegerProperty(PropInfo: PPropInfo): string;
    function StoreCharProperty(PropInfo: PPropInfo): string;
    function StoreEnumProperty(PropInfo: PPropInfo): string;
    function StoreFloatProperty(PropInfo: PPropInfo): string;
    function StoreStringProperty(PropInfo: PPropInfo): string;
    function StoreSetProperty(PropInfo: PPropInfo): string;
    function StoreClassProperty(PropInfo: PPropInfo): string;
    function StoreStringsProperty(PropInfo: PPropInfo): string;
    function StoreComponentProperty(PropInfo: PPropInfo): string;
    function StoreLStringProperty(PropInfo: PPropInfo): string;
    function StoreWCharProperty(PropInfo: PPropInfo): string;
    function StoreVariantProperty(PropInfo: PPropInfo): string;
    procedure LoadLStringProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadWCharProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadVariantProperty(const S: string; PropInfo: PPropInfo);
    function StoreInt64Property(PropInfo: PPropInfo): string;
    procedure LoadInt64Property(const S: string; PropInfo: PPropInfo);
    procedure LoadIntegerProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadCharProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadEnumProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadFloatProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadStringProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadSetProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadClassProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadStringsProperty(const S: string; PropInfo: PPropInfo);
    procedure LoadComponentProperty(const S: string; PropInfo: PPropInfo);
    function CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;
    procedure FreeInfoLists(Info: TStrings);
  protected
    function ReadString(const ASection, Item, Default: string): string; virtual;
    procedure WriteString(const ASection, Item, Value: string); virtual;
    procedure EraseSection(const ASection: string); virtual;
    function GetItemName(const APropName: string): string; virtual;
    function CreateStorage: TPropsFiler; virtual;
  public
    constructor Create(AIniFile: TCustomIniFile; const ASection: string);
    procedure StoreAnyProperty(PropInfo: PPropInfo);
    procedure LoadAnyProperty(PropInfo: PPropInfo);
    procedure StoreProperties(PropList: TStrings);
    procedure LoadProperties(PropList: TStrings);
    procedure LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);
    procedure StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);
    property AObject: TObject read FObject write FObject;
    property Prefix: string read FPrefix write FPrefix;
    property Section: string read FSection;
  end;
{$ENDIF}

{ TvgThreadList }
  TvgThreadList = class
  private
{$IFDEF _D4_}
    FLock: TMultiReadExclusiveWriteSynchronizer;
{$ELSE}
    FLock: TRTLCriticalSection;
{$ENDIF}
    FItems: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): Pointer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BeginRead;
    procedure EndRead;
    procedure BeginWrite;
    procedure EndWrite;
    procedure Lock;
    procedure Unlock;
    function IndexOf(Item: Pointer): Integer;
    function Add(Item: Pointer): Integer;
    procedure Insert(Index: Integer; Item: Pointer);
    procedure Remove(Item: Pointer);
    procedure Clear;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: Pointer read GetItem; default;
  end;

  TCustomPoolManager = class;

{ TCustomPoolInstance }
  TCustomPoolInstance = class(TObject)
  private
    FInUse: Boolean;
    FPoolManager: TCustomPoolManager;
  public
    property PoolManager: TCustomPoolManager read FPoolManager;
    property InUse: Boolean read FInUse;
  end;

{ TCustomPoolManager }
  TCustomPoolManager = class(TObject)
  private
    FItems: TvgThreadList;
    FMaxCount: Integer;
    FTimeout: DWord;
    FSemaphore: THandle;
    function GetCount: Integer;
    function GetItem(Index: Integer): TCustomPoolInstance;
  protected
    function InternalCreateNewInstance: TCustomPoolInstance; virtual; abstract;
    function CreateNewInstance: TCustomPoolInstance;
    function GetLock(Instance: TCustomPoolInstance): Boolean;
    procedure LockedInstance(Instance: TCustomPoolInstance; Value: Boolean); virtual;
    procedure CheckLocked(Instance: TCustomPoolInstance; var InUse: Boolean); virtual;
  public
    constructor Create(AMaxCount: Integer; ATimeout: DWord);
    destructor Destroy; override;
    procedure Clear;
    procedure ClearUnused;
    procedure Lock;
    procedure Unlock;
    function LockInstance: TCustomPoolInstance;
    procedure UnlockInstance(Instance: TCustomPoolInstance);
    property Items[Index: Integer]: TCustomPoolInstance read GetItem;
    property Count: Integer read GetCount;
    property Timeout: DWord read FTimeout;
    property MaxCount: Integer read FMaxCount;
  end;

{ TComponentPoolInstance }
  TComponentPoolInstance = class(TCustomPoolInstance)
  private
    FComponent: TComponent;
  public
    destructor Destroy; override;
    property Component: TComponent read FComponent write FComponent;
  end;

{ TComponentPoolManager }
  TComponentPoolManager = class(TCustomPoolManager)
  private
    FComponentClass: TComponentClass;
  protected
    function CreateComponent(Instance: TCustomPoolInstance): TComponent; virtual;
    function InternalCreateNewInstance: TCustomPoolInstance; override;
    procedure CheckLocked(Instance: TCustomPoolInstance; var InUse: Boolean); override;
  public
    constructor Create(AComponentClass: TComponentClass;
      AMaxCount: Integer; ATimeout: DWord);
    property ComponentClass: TComponentClass read FComponentClass;
  end;

{$IFDEF _D3_}
{ TIntfPoolInstance }
  TIntfPoolInstance = class(TCustomPoolInstance)
  private
    FUnk: IUnknown;
    function GetDispatch: IDispatch;
    function GetVariant: OleVariant;
  public
    destructor Destroy; override;
    property AsDispatch: IDispatch read GetDispatch;
    property AsUnknown: IUnknown read FUnk write FUnk;
    property AsVaraint: OleVariant read GetVariant;
  end;

{ TIntfPoolManager }
  TIntfPoolManager = class(TCustomPoolManager)
  protected
    function InternalCreateNewInstance: TCustomPoolInstance; override;
    function CreateUnknown(Instance: TCustomPoolInstance): IUnknown; virtual; abstract;
  public
    function LockInstance: TIntfPoolInstance;
  end;
{$ENDIF}

  TSignature = array [0..3] of Char;

{ TCompressor }
  TCompressor = class
  private
    FBuff, FData: Pointer;
    FBuffSize: Integer;
    FStream: TStream;
  protected
    property Buff: Pointer read FBuff;
    property BuffSize: Integer read FBuffSize;
    property Data: Pointer read FData;
    property Stream: TStream read FStream;
  public
    constructor Create; virtual;
    procedure Compress(AStream: TStream; const ABuff; ACount: Integer; AData: Pointer); virtual;
    procedure UnCompress(AStream: TStream; const ABuff; ACount: Integer; AData: Pointer); virtual;
    class function Sign: TSignature; virtual;
  end;

{ TBlockCompressor }
  TBlockCompressor = class(TCompressor)
  private
    FSourcePos: Integer;
  protected
    procedure GetBlock(var Buffer; Count: Integer; var ActualCount: Integer);
    procedure PutBlock(var Buffer; Count: Integer; var ActualCount: Integer);
    property SourcePos: Integer read FSourcePos;
  end;

  TCompressorClass = class of TCompressor;

{ TCompressorList }
  TCompressorList = class
  private
    FItems: TList;
    function GetCompressor(Index: Integer): TCompressorClass;
    function GetCount: Integer;
  public
    destructor Destroy; override;
    function CreateCompressor(Sign: TSignature): TCompressor;
    function FindCompressor(Sign: TSignature): TCompressorClass;
    procedure RegisterCompressor(CompressorClass: TCompressorClass);
    procedure UnRegisterCompressor(CompressorClass: TCompressorClass);
    property Compressors[Index: Integer]: TCompressorClass read GetCompressor;
    property Count: Integer read GetCount;
  end;

  { TReadMemoryStream }
  TReadMemoryStream = class (TCustomMemoryStream)
  public
    procedure SetPointer(Ptr: Pointer; Size: Longint);
    function Write(const Buffer; Count: Longint): Longint; override;
  end;

  TFileAccessModes   = (famWrite, famRead);
  TFileAccessMode    = set of TFileAccessModes;

  TFileShareModes    = (fsmRead, fsmWrite, fsmDelete);
  TFileShareMode     = set of TFileShareModes;

  TFileCreationMode  = (fcmCreateNew, fcmCreateAlways, fcmOpenExisting,
    fcmOpenAlways, fcmTruncateExisting);

{ TWinFileStream }
  TWinFileStream = class(THandleStream)
  public
    constructor Create(const FileName: TFileName; Access: TFileAccessMode;
      Share: TFileShareMode; Creation: TFileCreationMode; FileAttrsAndFlags: DWord;
      lpSecurity: PSecurityAttributes; TemplateHandle: Integer);
    destructor Destroy; override;
  end;

{ TClassItem }
  TClassItem = class
  private
    FClassType: TClass;
    FData: Pointer;
    FInfo: string;
  public
    constructor Create(AClassType: TClass; AData: Pointer; AInfo: string);
    property GetClassType: TClass read FClassType;
    property Data: Pointer read FData write FData;
    property Info: string read FInfo write FInfo;
  end;

{ TClassList }
  TClassName = type ShortString;

  TClassList = class
  private
    FItems: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): TClassItem;
  protected
    function InternalRegister(AClass: TClass; const AData: Pointer; const AInfo: string; Inheritance: Boolean): TClassItem; virtual;
    procedure InternalUnRegister(AClass: TClass; Index: Integer); virtual;
  public
    destructor Destroy; override;
    procedure Clear;
    function ClassItemByName(const AClassName: TClassName): TClassItem;
    function FindClassItem(const AClassName: TClassName): TClassItem;
    function IndexOf(const AClassName: TClassName): Integer;
    function IndexOfClass(AClass: TClass; Inheritance: Boolean): Integer;
    procedure RegisterClass(AClass: TClass; const AData: Pointer; const AInfo: string; Inheritance: Boolean);
    procedure UnregisterClass(AClass: TClass);
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TClassItem read GetItem; default;
  end;

{$IFDEF _D3_}
{ TEnumeratorObject }
  TEnumeratorObject = class(TInterfacedObject, IEnumVariant)
  private
    FFetched: LongWord;
  protected
    { IEnumVariant }
    {$IFDEF _D5_}
    function Next(celt: LongWord; var rgvar : OleVariant;
      out pceltFetched: LongWord): HResult; stdcall;
    function Skip(celt: LongWord): HResult; stdcall;
    {$ELSE}
    function Next(celt: Longint; out elt;
      pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    {$ENDIF}
    function Reset: HResult; stdcall;
    function Clone(out Enum: IEnumVariant): HResult; stdcall;
  public
    function Fetch(Index: LongWord; var VarResult: OleVariant): HResult; virtual;
    function CreateEnumerator: TEnumeratorObject; virtual;
    function GetCount: LongWord; virtual;
    property Fetched: LongWord read FFetched;
  end;

  TEnumeratorObjectClass = class of TEnumeratorObject;
{$ENDIF}

{ TPropInfoList }
procedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);

{ TPropFiler }
function CreateStoredItem(const CompName, PropName: string): string;
function ParseStoredItem(Root: TComponent; const Item: string; var CompName, PropName: string): Boolean;
function ReplaceComponentName(Root: TComponent; const Item, CompName: string): string;
function GetEnumName(TypeInfo: PTypeInfo; Value: Integer): string;

function CompressorList: TCompressorList;

{ --- Buffer compression }
procedure Compress(Sign: TSignature; Stream: TStream; const Buff; Count: Integer; Data: Pointer);
procedure UnCompress(Sign: TSignature; Stream: TStream; const Buff; Count: Integer; Data: Pointer);

const
  famAccessAll = [famRead, famWrite];

  ThreadPriorities: array [TThreadPriority] of Integer =
   (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
    THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
    THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);

  CreationMode: array [TFileCreationMode] of Integer = (
    CREATE_NEW, CREATE_ALWAYS, OPEN_EXISTING, OPEN_ALWAYS, TRUNCATE_EXISTING);

{ TPropFiler }
const
  sCount                     = 'Count';
  sItem                      = 'Item%d';
  sNull                      = '(null)';
  sPropNameDelimiter         = '_';

implementation
uses Messages, Consts, vgVCLRes, vgUtils;

var
  FTlsBuffers: TList = nil;
  FTlsLock: TRTLCriticalSection;

function CreateStoredItem(const CompName, PropName: string): string;
begin
  Result := '';
  if (CompName <> '') and (PropName <> '') then
    Result := CompName + '.' + PropName;
end;

function ParseStoredItem(Root: TComponent; const Item: string; var CompName, PropName: string): Boolean;
var
  I: Integer;
begin
  Result := False;
  if Length(Item) = 0 then Exit;
  I := Pos('.', Item);
  if I > 0 then
  begin
    CompName := Trim(Copy(Item, 1, I - 1));
    PropName := Trim(Copy(Item, I + 1, MaxInt));
  end else if Assigned(Root) then
  begin
    CompName := Root.Name;
    PropName := Item
  end else begin
    CompName := '';
    PropName := '';
  end;
  Result := (Length(CompName) > 0) and (Length(PropName) > 0);
end;