vgtools.pas

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

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff Delphi VCL Library         }
{         Non-visual components                         }
{                                                       }
{         Copyright (c) 1997, 2000                      }
{                                                       }
{*******************************************************}

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

unit vgTools;

interface
uses Messages, Windows, SysUtils, Classes, vgSystem, TypInfo;

type
{ TItem }
  TItemList = class;

  TItem = class(TComponent)
  private
    FItemList: TItemList;
    function GetIndex: Integer;
    procedure SetIndex(Value: Integer);
    procedure SetItemList(Value: TItemList);
  protected
    procedure ItemEvent(Event: Integer); virtual;
    function GetItemName: string; virtual;
    procedure Notify(Event: Integer; Data: Pointer); virtual;
    procedure SetParentComponent(AParent: TComponent); override;
  public
    destructor Destroy; override;
    function GetParentComponent: TComponent; override;
    function HasParent: Boolean; override;
    property Index: Integer read GetIndex write SetIndex stored False;
    property ItemList: TItemList read FItemList write SetItemList;
  end;

{ TItemList }
  TItemListDesigner = class;

  TItemList = class(TItem)
  private
    FDesigner: TItemListDesigner;
    FItems: TList;
    FUpdateCount: Integer;
    function GetCount: Integer;
    function GetInUpdate: Boolean;
    function GetItem(Index: Integer): Pointer;
  protected
    procedure ItemListEvent(Item: TItem; Event: Integer); virtual;
    procedure GetChildren(Proc: TGetChildProc{$IFDEF _D3_}; Root: TComponent{$ENDIF}); override;
    procedure SetChildOrder(Component: TComponent; Order: Integer); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure NotifyChildren(Event: Integer; Data: Pointer);
    procedure InsertItem(Item: TItem); virtual;
    procedure RemoveItem(Item: TItem); virtual;
    procedure SetName(const Value: TComponentName); override;
    property UpdateCount: Integer read FUpdateCount;
    property InUpdate: Boolean read GetInUpdate;
  public
    destructor Destroy; override;
    procedure DestroyingChildren;
    procedure BeginUpdate; virtual;
    procedure EndUpdate; virtual;
    procedure Clear; virtual;
    function FindItem(const AName: string): TItem;
    function ItemByName(const AName: string): TItem;
    function HasChildren: Boolean;
    function IndexOf(Item: TItem): Integer;
    procedure Sort(Compare: TListSortCompare); virtual;
    property Count: Integer read GetCount;
    property Designer: TItemListDesigner read FDesigner;
    property Items[Index: Integer]: Pointer read GetItem; default;
  end;

{ TItemListDesigner }
  TItemListDesigner = class(TObject)
  private
    FItemList: TItemList;
  public
    constructor Create(AItemList: TItemList);
    destructor Destroy; override;
    procedure Event(Item: TItem; Event: Integer); virtual;
    property ItemList: TItemList read FItemList;
  end;

{ TOwnerList }
  PComponent = ^TComponent;
  TOwnerManager = class;

  TOwnerList = class(TItem)
  private
    FComponent: TComponent;
    FVariable: PComponent;
    FOwners: TList;
    procedure SetComponent(AComponent: TComponent; AVariable: PComponent);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    destructor Destroy; override;
    procedure InsertOwner(AOwner: TComponent);
    procedure RemoveOwner(AOwner: TComponent);
    property Component: TComponent read FComponent;
    property Variable: PComponent read FVariable;
  end;

{ TOwnerManager }
  TOwnerManager = class(TItemList)
  private
    function GetItem(Index: Integer): TOwnerList;
  public
    function FindOwnerList(Variable: PComponent): TOwnerList;
    function IndexOfVariable(Variable: PComponent): Integer;
    procedure InsertOwner(Variable: PComponent; ComponentClass: TComponentClass; AOwner: TComponent);
    procedure RemoveOwner(Variable: PComponent; AOwner: TComponent);
    property Items[Index: Integer]: TOwnerList read GetItem;
  end;


{ TvgThread }
  TvgThread = class(TComponent)
  private
    FThread: TThreadEx;
    FSyncMethod: TNotifyEvent;
    FSyncParams: Pointer;
    FStreamedSuspended: Boolean;
    FOnExecute: TNotifyEvent;
    FOnException: TNotifyEvent ;
    procedure InternalSynchronize;
    function GetHandle: THandle;
    function GetOnTerminate: TNotifyEvent;
    procedure SetOnTerminate(Value: TNotifyEvent);
    function GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    function GetReturnValue: Integer;
    procedure SetReturnValue(Value: Integer);
    function GetSuspended: Boolean;
    procedure SetSuspended(Value: Boolean);
    function GetTerminated: Boolean;
  protected
    procedure DoExecute(Sender: TObject); virtual;
    procedure DoException(Sender: TObject); virtual;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure Synchronize(Method: TThreadMethod);
    procedure SynchronizeEx(Method: TNotifyEvent; Params: Pointer);
    procedure Suspend;
    procedure Resume;
    procedure Terminate(Hard: Boolean);
    function WaitFor: Integer;
    property ReturnValue: Integer read GetReturnValue write SetReturnValue;
    property Handle: THandle read GetHandle;
    property Terminated: Boolean read GetTerminated;
  published
    property Priority: TThreadPriority read GetPriority write SetPriority;
    property Suspended: Boolean read GetSuspended write SetSuspended default True;
    property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;
    property OnTerminate: TNotifyEvent read GetOnTerminate write SetOnTerminate;
    property OnException: TNotifyEvent read FOnException write FOnException;
  end;

{ TBroadcaster }
  TBroadcastEvent = procedure (Sender: TObject; var Msg: TMessage;
    Item, Data: TObject; var Handled: Boolean) of object;

  TBroadcaster = class(TComponent)
  private
    FItems: TList;
    FDatas: TList;
    FOnBroadcast: TBroadcastEvent;
    function GetCount: Integer;
    function GetData(Index: Integer): TObject;
    function GetItem(Index: Integer): TObject;
  protected
    { Protected declarations }
    function BroadcastMessage(var Msg: TMessage; Item, Data: TObject): Boolean; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Broadcast(Msg: Cardinal; WParam, LParam: Longint): Longint; virtual;
    function IndexOf(AObject: TObject): Integer;
    procedure InsertObject(AObject, AData: TObject);
    procedure RemoveObject(AObject: TObject);
    property Count: Integer read GetCount;
    property Data[Index: Integer]: TObject read GetData;
    property Item[Index: Integer]: TObject read GetItem;
  published
    { Published declarations }
    property OnBroadcast: TBroadcastEvent read FOnBroadcast write FOnBroadcast;
  end;

{ TNamedCollectionItem }
  TNamedCollectionItem = class(TCollectionItem)
  private
    FName: string;
  protected
    function GetDisplayName: string; {$IFDEF _D3_}override;{$ENDIF}
    procedure SetDisplayName(const Value: string); {$IFDEF _D3_}override;{$ENDIF}
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Name: string read FName write SetDisplayName;
  end;

{ TNamedItemsCollection }
{$IFDEF _D4_}
  TNamedItemsCollection = class(TOwnedCollection)
{$ELSE}
  TNamedItemsCollection = class(TCollection)
{$ENDIF}
  public
    function Duplicates: Boolean; virtual;
    function FindItem(const Name: string): TNamedCollectionItem;
    function ItemByName(const Name: string): TNamedCollectionItem;
    function IndexOf(const Name: string): Integer;
  end;

const
  { Item events }
  ieItemChanged              =  0;
  ieItemListChanged          = -1;
  ieItemListLast             = ieItemListChanged;

implementation
uses Consts, vgVCLRes, vgUtils;

{ TItem }
destructor TItem.Destroy;
begin
  SetItemList(nil);
  inherited;
end;

function TItem.GetIndex: Integer;
begin
  if Assigned(FItemList) then
    Result := FItemList.IndexOf(Self) else
    Result := -1;
end;

procedure TItem.ItemEvent(Event: Integer);
begin
  if Assigned(FItemList) then FItemList.ItemListEvent(Self, Event);
end;

function TItem.GetItemName: string;
begin
  Result := '';
end;

function TItem.GetParentComponent: TComponent;
begin
  Result := ItemList;
end;

function TItem.HasParent: Boolean;
begin
  Result := Assigned(FItemList);
end;

procedure TItem.Notify(Event: Integer; Data: Pointer);
begin
end;

procedure TItem.SetIndex(Value: Integer);
var
  CurIndex, Count: Integer;
begin
  CurIndex := GetIndex;
  if CurIndex >= 0 then
  begin
    Count := FItemList.FItems.Count;
    if Value < 0 then Value := 0;
    if Value >= Count then Value := Count - 1;
    if Value <> CurIndex then
    begin
      FItemList.FItems.Delete(CurIndex);
      FItemList.FItems.Insert(Value, Self);
      ItemEvent(ieItemListChanged);
    end;
  end;
end;

procedure TItem.SetItemList(Value: TItemList);
begin
  if (FItemList <> Value) then
  begin
    if Assigned(FItemList) then FItemList.RemoveItem(Self);
    if Assigned(Value) then Value.InsertItem(Self);
  end;
end;

procedure TItem.SetParentComponent(AParent: TComponent);
begin
  if (AParent is TItemList) then ItemList := AParent as TItemList;
end;

{ TItemList }
destructor TItemList.Destroy;
begin
  Clear;
  inherited;
end;

procedure TItemList.DestroyingChildren;
var
  I: Integer;
  Item: TItem;
begin
  Destroying;
  for I := 0 to Count - 1 do
  begin
    Item := Items[I];
    if Item is TItemList then
      TItemList(Item).DestroyingChildren;
  end;
end;

function TItemList.GetCount: Integer;
begin
  Result := ListCount(FItems);
end;

function TItemList.GetInUpdate: Boolean;
begin
  Result := FUpdateCount > 0;
end;

function TItemList.GetItem(Index: Integer): Pointer;
begin
  Result := ListItem(FItems, Index);
end;

procedure TItemList.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TItemList.EndUpdate;
begin
  Dec(FUpdateCount);
end;

function TItemList.FindItem(const AName: string): TItem;
var
  I: Integer;
begin
  if Assigned(FItems) then
    for I := 0 to FItems.Count - 1 do
    begin
      Result := FItems.List^[I];
      if AnsiCompareText(Result.GetItemName, AName) = 0 then Exit;
    end;
  Result := nil;
end;

function TItemList.ItemByName(const AName: string): TItem;
begin
  Result := FindItem(AName);
  if not Assigned(Result) then
    raise EInvalidOp.Create(FmtLoadStr(SItemNotFound, [AName]));
end;

procedure TItemList.Clear;
begin
  ListDestroyAll(FItems);
end;

procedure TItemList.ItemListEvent(Item: TItem; Event: Integer);
begin
  if Assigned(FDesigner) then FDesigner.Event(Item, Event);
end;

procedure TItemList.GetChildren(Proc: TGetChildProc{$IFDEF _D3_}; Root: TComponent{$ENDIF});
var
  I: Integer;
  Item: TItem;
begin
  for I := 0 to ListCount(FItems) - 1 do
  begin
    Item := FItems.List^[I];
    Proc(Item);
  end;
end;

procedure TItemList.SetChildOrder(Component: TComponent; Order: Integer);
begin
  if ListIndexOf(FItems, Component) >= 0 then (Component as TItem).Index := Order;
end;

procedure TItemList.Notification(AComponent: TComponent; Operation: TOperation);
var
  I: Integer;
begin
  inherited;
  if (Operation = opRemove) then
  begin
    I := ListIndexOf(FItems, AComponent);
    if I >= 0 then RemoveItem(AComponent as TItem);
  end;
end;

procedure TItemList.NotifyChildren(Event: Integer; Data: Pointer);
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    TItem(Items[I]).Notify(Event, Data);
end;

function TItemList.HasChildren: Boolean;
begin
  Result := Assigned(FItems);
end;

function TItemList.IndexOf(Item: TItem): Integer;
begin
  Result := ListIndexOf(FItems, Item);
end;

procedure TItemList.InsertItem(Item: TItem);
begin
  if ListIndexOf(FItems, Item) < 0 then
  begin
    FreeNotification(Item);
    ListAdd(FItems, Item);
    Item.FItemList := Self;
    ItemListEvent(Item, ieItemListChanged);
  end;
end;

procedure TItemList.RemoveItem(Item: TItem);
begin
  if ListIndexOf(FItems, Item) >= 0 then
  begin
    ListRemove(FItems, Item);
    Item.FItemList := nil;
    ItemListEvent(Item, ieItemListChanged);
  end;
end;

procedure TItemList.SetName(const Value: TComponentName);
var
  I: Integer;
  OldName, ItemName, NamePrefix: TComponentName;
  Item: TItem;
begin
  OldName := Name;
  inherited SetName(Value);
  if (csDesigning in ComponentState) and (Name <> OldName) then
    { In design mode the name of the items should track the item list name }
    for I := 0 to ListCount(FItems) - 1 do
    begin
      Item := FItems.List^[I];
      if Item.Owner = Owner then
      begin
        ItemName := Item.Name;
        NamePrefix := ItemName;