vgtools.pas

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

        if Length(NamePrefix) > Length(OldName) then
        begin
          SetLength(NamePrefix, Length(OldName));
          if CompareText(OldName, NamePrefix) = 0 then
          begin
            System.Delete(ItemName, 1, Length(OldName));
            System.Insert(Value, ItemName, 1);
            try
              Item.Name := ItemName;
            except
              on EComponentError do {Ignore rename errors };
            end;
          end;
        end;
      end;
    end;
end;

procedure TItemList.Sort(Compare: TListSortCompare);
begin
  ListSort(FItems, Compare);
end;

{ TItemListDesigner }
constructor TItemListDesigner.Create(AItemList: TItemList);
begin
  FItemList := AItemList;
  FItemList.FDesigner := Self;
end;

destructor TItemListDesigner.Destroy;
begin
  FItemList.FDesigner := nil;
  inherited;
end;

procedure TItemListDesigner.Event(Item: TItem; Event: Integer);
begin
end;

{ TOwnerList }
destructor TOwnerList.Destroy;
begin
  SetComponent(nil, nil);
  inherited;
end;

procedure TOwnerList.InsertOwner(AOwner: TComponent);
begin
  if Assigned(FComponent) and Assigned(AOwner) then
  begin
    FreeNotification(AOwner);
    ListAdd(FOwners, AOwner);
  end;
end;

procedure TOwnerList.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and Assigned(FComponent) then
    if (AComponent = FComponent) then Destroy else RemoveOwner(AComponent);
end;

procedure TOwnerList.RemoveOwner(AOwner: TComponent);
var
  I: Integer;
begin
  I := ListIndexOf(FOwners, AOwner);
  if (I >= 0) then
  begin
    ListDelete(FOwners, I);
    if not Assigned(FOwners) then
    begin
      if Assigned(FVariable) then FVariable^ := nil;
      FComponent.Free;
    end;
  end;
end;

procedure TOwnerList.SetComponent(AComponent: TComponent; AVariable: PComponent);
begin
  if (FComponent <> AComponent) then
  begin
    ListClear(FOwners);
    FComponent := AComponent;
    FVariable := AVariable;
    if Assigned(FComponent) then FreeNotification(FComponent) else FVariable := nil;
  end;
end;

{ TOwnerManager }
function TOwnerManager.GetItem(Index: Integer): TOwnerList;
begin
  Result := inherited Items[Index];
end;

function TOwnerManager.FindOwnerList(Variable: PComponent): TOwnerList;
var
  I: Integer;
begin
  I := IndexOfVariable(Variable);
  if I >= 0 then Result := Items[I] else Result := nil;
end;

function TOwnerManager.IndexOfVariable(Variable: PComponent): Integer;
var
  Item: TOwnerList;
begin
  for Result := 0 to Count - 1 do
  begin
    Item := Items[Result];
    if Item.Variable = Variable then Exit;
  end;
  Result := -1;
end;

procedure TOwnerManager.InsertOwner(Variable: PComponent; ComponentClass: TComponentClass; AOwner: TComponent);
var
  Item: TOwnerList;
begin
  Item := FindOwnerList(Variable);
  if not Assigned(Item) then
  begin
    Item := TOwnerList.Create(Self);
    try
      Item.ItemList := Self;
      Variable^ := ComponentClass.Create(Item);
      try
        Item.SetComponent(Variable^, Variable);
      except
        Variable^.Free;
        Variable^ := nil;
        raise;
      end;
    except
      Item.Free;
      raise;
    end;
  end;
  Item.InsertOwner(AOwner);
end;

procedure TOwnerManager.RemoveOwner(Variable: PComponent; AOwner: TComponent);
var
  Item: TOwnerList;
begin
  Item := FindOwnerList(Variable);
  if Assigned(Item) then Item.RemoveOwner(AOwner);
end;

{ TvgThread }
type
  TThreadHack = class(TThreadEx);

constructor TvgThread.Create(AOwner: TComponent);
begin
  inherited;
  FStreamedSuspended := True;
  FThread := TThreadEx.Create(True);
  FThread.OnExecute := DoExecute;
  FThread.OnException := DoException;
end;

destructor TvgThread.Destroy;
begin
  Terminate(True);
  FThread.Free;
  inherited;
end;

procedure TvgThread.DoExecute(Sender: TObject);
begin
  if Assigned(FOnExecute) then FOnExecute(Self);
end;

procedure TvgThread.DoException(Sender: TObject);
begin
  if Assigned(FOnException) then FOnException(Self);
end;


function TvgThread.GetHandle: THandle;
begin
  Result := FThread.Handle;
end;

function TvgThread.GetTerminated: Boolean;
begin
  Result := TThreadHack(FThread).Terminated;
end;

function TvgThread.GetOnTerminate: TNotifyEvent;
begin
  Result := FThread.OnTerminate;
end;

function TvgThread.GetPriority: TThreadPriority;
begin
  Result := FThread.Priority;
end;

function TvgThread.GetReturnValue: Integer;
begin
  Result := TThreadHack(FThread).ReturnValue;
end;

function TvgThread.GetSuspended: Boolean;
begin
  if not (csDesigning in ComponentState) then
    Result := FThread.Suspended else
    Result := FStreamedSuspended;
end;

procedure TvgThread.Execute;
begin
  Terminate(True);
  FThread.Resume;
end;

procedure TvgThread.Loaded;
begin
  inherited;
  SetSuspended(FStreamedSuspended);
end;

procedure TvgThread.SetOnTerminate(Value: TNotifyEvent);
begin
  FThread.OnTerminate := Value;
end;

procedure TvgThread.SetPriority(Value: TThreadPriority);
begin
  FThread.Priority := Value;
end;

procedure TvgThread.SetReturnValue(Value: Integer);
begin
  TThreadHack(FThread).ReturnValue := Value;
end;

procedure TvgThread.SetSuspended(Value: Boolean);
begin
  if not (csDesigning in ComponentState) then
  begin
    if (csLoading in ComponentState) then
      FStreamedSuspended := Value else
      FThread.Suspended := Value;
  end else
    FStreamedSuspended := Value;
end;

procedure TvgThread.Suspend;
begin
  FThread.Suspend;
end;

procedure TvgThread.Synchronize(Method: TThreadMethod);
begin
  TThreadHack(FThread).Synchronize(Method);
end;

procedure TvgThread.InternalSynchronize;
begin
  FSyncMethod(FSyncParams);
end;

procedure TvgThread.SynchronizeEx(Method: TNotifyEvent; Params: Pointer);
begin
  if Assigned(Method) then
  begin
    FSyncMethod := Method; FSyncParams := Params;
    try
      TThreadHack(FThread).Synchronize(InternalSynchronize);
    finally
      FSyncMethod := nil; FSyncParams := nil;
    end;
  end;
end;

procedure TvgThread.Resume;
begin
  FThread.Resume;
end;

procedure TvgThread.Terminate(Hard: Boolean);
var
  FTmp: TThreadEx;
begin
  if Hard then
  begin
    TerminateThread(FThread.Handle, 0);
    FTmp := TThreadEx.Create(True);
    try
      FTmp.Priority := Self.Priority;
      FTmp.OnExecute := DoExecute;
      FTmp.OnTerminate := Self.OnTerminate;
    except
      FTmp.Free;
      raise;
    end;
    FThread.Free;
    FThread := FTmp;
  end else
    FThread.Terminate;
end;

function TvgThread.WaitFor: Integer;
begin
  Terminate(True);
  Result := FThread.WaitFor;
end;

{ TBroadcaster }

constructor TBroadcaster.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TList.Create;
  FDatas := TList.Create;
end;

destructor TBroadcaster.Destroy;
begin
  FItems.Free;
  FDatas.Free;
  inherited;
end;

function TBroadcaster.Broadcast(Msg: Cardinal; WParam, LParam: Longint): Longint;
var
  I: Integer;
  Message: TMessage;
begin
  Message.Msg := Msg;
  Message.WParam := WParam;
  Message.LParam := LParam;
  Message.Result := 0;
  for I := 0 to Count - 1 do
    if BroadcastMessage(Message, Item[I], Data[I]) then Break;
  Result := Message.Result;
end;

function TBroadcaster.BroadcastMessage(var Msg: TMessage; Item, Data: TObject): Boolean;
begin
  Result := False;
  if Assigned(FOnBroadcast) then FOnBroadcast(Self, Msg, Item, Data, Result);
end;

function TBroadcaster.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TBroadcaster.GetData(Index: Integer): TObject;
begin
  Result := FDatas[Index];
end;

function TBroadcaster.GetItem(Index: Integer): TObject;
begin
  Result := FItems[Index];
end;

function TBroadcaster.IndexOf(AObject: TObject): Integer;
begin
  Result := FItems.IndexOf(AObject);
end;

procedure TBroadcaster.InsertObject(AObject, AData: TObject);
var
  I: Integer;
begin
  I := FItems.IndexOf(AObject);
  if I < 0 then
  begin
    FItems.Add(AObject);
    FDatas.Add(AData);
    if (AObject is TComponent) then
      FreeNotification(TComponent(AObject));
  end;
end;

procedure TBroadcaster.RemoveObject(AObject: TObject);
var
  I: Integer;
begin
  I := FItems.IndexOf(AObject);
  if I >= 0 then
  begin
    FItems.Delete(I);
    FDatas.Delete(I);
  end;
end;

procedure TBroadcaster.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) then RemoveObject(AComponent);
end;

{ TNamedCollectionItem }

procedure TNamedCollectionItem.Assign(Source: TPersistent);
begin
  if Source is TNamedCollectionItem then
    Name := TNamedCollectionItem(Source).Name
  else
    inherited;
end;

function TNamedCollectionItem.GetDisplayName: string;
begin
  if FName = '' then
  {$IFDEF _D3_}
    Result := inherited GetDisplayName
  {$ELSE}
    Result := ClassName
  {$ENDIF}
  else
    Result := FName;
end;

procedure TNamedCollectionItem.SetDisplayName(const Value: string);
begin
  if (Value <> '') and (AnsiCompareText(Value, FName) <> 0) and
    (Collection is TNamedItemsCollection) then
    with TNamedItemsCollection(Collection) do
      if not Duplicates and (IndexOf(Value) >= 0) then
        raise Exception.Create(FmtLoadStr(SDuplicateItem, [Value]));
  FName := Value;
  inherited;
end;

{ TNamedItemsCollection }
function TNamedItemsCollection.Duplicates: Boolean;
begin
  Result := False;
end;

function TNamedItemsCollection.FindItem(const Name: string): TNamedCollectionItem;
var
  I: Integer;
begin
  I := IndexOf(Name);
  if I >= 0 then
    Result := TNamedCollectionItem(Items[I]) else
    Result := nil;
end;

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

function TNamedItemsCollection.IndexOf(const Name: string): Integer;
begin
  for Result := 0 to Count - 1 do
    if AnsiCompareText(TNamedCollectionItem(Items[Result]).Name, Name) = 0 then Exit;
  Result := -1;
end;

end.