vgutils.pas

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

begin
  Len := 0;
  I := WordPosition(N, S, WordDelims);
  if I <> 0 then
    { find the end of the current word }
    while (I <= Length(S)) and not(S[I] in WordDelims) do
    begin
      { add the I'th character to result }
      Inc(Len);
      SetLength(Result, Len);
      Result[Len] := S[I];
      Inc(I);
    end;
  SetLength(Result, Len);
end;

procedure WideCharToNames(Names: PChar; NameCount: Byte; var WideNames: TNames; var Size: Word);
var
  I, N: Integer;
  Ch: WideChar;
begin
  I := 0;
  N := 0;
  Size := 0;
  repeat
    repeat
      Ch := WideChar(Names[I]);
      WideNames[I] := Char(Ch);
      Inc(Size);
      Inc(I);
    until Char(Ch) = #0;
    Inc(N);
  until N = NameCount;
end;

function ForEachString(Strings: TStrings; const Separator, StringMacro, Macro: string): string;
var
  I, Pos: Integer;
  S, Tmp: string;
begin
  Result := '';
  for I := 0 to Strings.Count - 1 do
  begin
    if I > 0 then Result := Result + Separator;
    S := Strings[I];
    Tmp := Macro;
    Pos := System.Pos(StringMacro, Tmp);
    while Pos > 0 do
    begin
      Delete(Tmp, Pos, Length(StringMacro));
      Insert(S, Tmp, Pos);
      Pos := System.Pos(StringMacro, Tmp);
    end;
    Result := Result + Tmp;
  end;
end;

function ListAdd(var List: TList; Item: Pointer): Pointer;
begin
  if List = nil then List := TList.Create;
  List.Add(Item);
  Result := Item;
end;

procedure ListClear(var List: TList);
asm
        JMP     FreeObject
end;

function ListCount(List: TList): Integer;
begin
  if Assigned(List) then Result := List.Count else Result := 0;
end;

function ListDelete(var List: TList; Index: Integer): Pointer;
begin
  Result := ListItem(List, Index);
  List.Delete(Index);
  if List.Count = 0 then ListDestroy(List);
end;

procedure ListDestroy(var List: TList);
asm
        JMP     FreeObject
end;

procedure ListDestroyAll(var List: TList);
begin
  if Assigned(List) then
  begin
    ListDestroyObjects(List);
    FreeObject(List);
  end;
end;

procedure ListDestroyObjects(List: TList);
var
  I: Integer;
begin
  if Assigned(List) then
    with List do
      for I := Count - 1 downto 0 do
        TObject(List^[I]).Free;
end;

procedure ListDestroyObjectsAll(var List: TList);
asm
        JMP     ListDestroyAll
end;

procedure ListFreeMem(List: TList);
var
  I: Integer;
  P: Pointer;
begin
  if Assigned(List) then
    with List do
    begin
      for I := 0 to Count - 1 do
      begin
        P := List^[I];
        FreeMem(P);
      end;
      Clear;
    end;
end;

procedure ListFreeMemAll(var List: TList);
begin
  ListFreeMem(List);
  FreeObject(List);
end;

procedure ListSort(List: TList; Compare: TListSortCompare);
begin
  if Assigned(List) then List.Sort(Compare);
end;

procedure ListError(Index: Integer);
begin
{$IFDEF _D3_}
  TList.Error(SListIndexError, Index);
{$ELSE}
  raise EListError.CreateRes(SListIndexError);
{$ENDIF}
end;

function ListIndexOf(List: TList; Item: Pointer): Integer;
begin
  if Assigned(List) then
    with List do Result := FindInteger(Integer(Item), List^, Count) else Result := -1;
end;

procedure ListInsert(var List: TList; Index: Integer; Item: Pointer);
begin
  if not Assigned(List) then List := TList.Create;
  List.Insert(Index, Item);
end;

function ListItem(List: TList; Index: Integer): Pointer;
begin
  if Assigned(List) then
    Result := List[Index]
  else begin
    Result := nil;
    ListError(Index);
  end;
end;

function ListRemove(var List: TList; Item: Pointer): Pointer;
var
  I: Integer;
begin
  I := ListIndexOf(List, Item);
  if I >= 0 then
    Result := ListDelete(List, I) else
    Result := nil;
end;

function ListRemoveLast(var List: TList): Pointer;
begin
  if Assigned(List) and (List.Count > 0) then
    Result := ListRemove(List, List.Last) else
    Result := nil;
end;

procedure QuickSortList(AList: TList; DataCompare, DataExchange: Pointer;
  Compare: TCompareItems; AExchange: TExchangeItems);

  procedure DoQuickSortList(L, R: Integer);
  var
    I, J: Integer;
    P: Pointer;
  begin
    with AList do
    repeat
      I := L;
      J := R;
      P := List^[(L + R) shr 1];
      repeat
        if (L <> R) then
        begin
          while Compare(DataCompare, List^[I], P) < 0 do Inc(I);
          while Compare(DataCompare, List^[J], P) > 0 do Dec(J);
        end;
        if I <= J then
        begin
          if I < J then
          begin
            if Assigned(AExchange) then
              AExchange(DataExchange, I, J)
            else begin
              P := List^[I];
              List^[I] := List^[J];
              List^[J] := P;
            end;
          end;
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then DoQuickSortList(L, J);
      L := I;
    until I >= R;
  end;

begin
  if Assigned(AList) then
    DoQuickSortList(0, AList.Count - 1);
end;

procedure ListAssign(var Dest: TList; Source: TList);
var
  Count: Integer;
begin
  Count := ListCount(Source);
  if Count > 0 then
  begin
    if not Assigned(Dest) then
      Dest := TList.Create;
    Dest.Count := Count;
    Move(Source.List^, Dest.List^, Count * SizeOf(Pointer));
  end else
    ListClear(Dest);
end;

function ListCheck(var List: TList): TList;
begin
  if not Assigned(List) then List := TList.Create;
  Result := List;
end;

procedure StringsAssignTo(List: TStrings; const Strings: Array of string);
var
  I: Integer;
begin
  List.BeginUpdate;
  try
    List.Clear;
    for I := Low(Strings) to High(Strings) do List.Add(Strings[I]);
  finally
    List.EndUpdate;
  end;
end;

procedure ArrayAssignTo(List: TStrings; var Strings: Array of string);
var
  I: Integer;
begin
  for I := Low(Strings) to High(Strings) do
    if I < List.Count then Strings[I] := List[I] else Strings[I] := '';
end;

function StringsHistoryInsertObject(List: TStrings; Index: Integer;
  const Value: string; AObject: TObject; MaxCount: Integer): Integer;
var
  I: Integer;
begin
  List.BeginUpdate;
  try
    Result := List.IndexOf(Value);
    if Result >= 0 then
    begin
      List.Move(Result, Index);
      List.Objects[Index] := AObject;
    end else begin
      List.InsertObject(Index, Value, AObject);
      Result := Index;
    end;
    I := List.Count - 1;
    while I >= MaxCount do
    begin
      List.Delete(I);
      Dec(I);
    end;
    Result := Max(Result, I);
  finally
    List.EndUpdate;
  end;
end;

function StringsHistoryInsert(List: TStrings; Index: Integer;
  const Value: string; MaxCount: Integer): Integer;
begin
  Result := StringsHistoryInsertObject(List, Index, Value, nil, MaxCount);
end;

function StringsHistoryAddObject(List: TStrings; const Value: string;
  AObject: TObject; MaxCount: Integer): Integer;
begin
  Result := StringsHistoryInsertObject(List, List.Count, Value, AObject, MaxCount);
end;

function StringsHistoryAdd(List: TStrings; const Value: string; MaxCount: Integer): Integer;
begin
  Result := StringsHistoryInsertObject(List, List.Count, Value, nil, MaxCount);
end;

function IsClass(AClass: TClass; ParentClass: TClass): Boolean;
begin
  Result := (ParentClass = nil);
  if not Result then
    while (AClass <> nil) do
    begin
      if AClass = ParentClass then
      begin
        Result := True;
        Break;
      end;
      AClass := AClass.ClassParent;
    end;
end;

type
  TClassRegistrator = class(TObject)
    class procedure RegisterClass(Instance: TComponent);
  end;

  TComponentHack = class(TComponent)
  end;

  TSetNameHelper = class
    OldName: string;
    procedure SetName(Reader: TReader; Component: TComponent; var Name: string);
  end;

class procedure TClassRegistrator.RegisterClass(Instance: TComponent);
begin
  Classes.RegisterClass(TComponentClass(Instance.ClassType));
  TComponentHack(Instance).GetChildren(TClassRegistrator.RegisterClass {$IFDEF _D3_}, nil {$ENDIF});
end;

procedure TSetNameHelper.SetName(Reader: TReader; Component: TComponent; var Name: string);
begin
  Name := UniqueName(Component, OldName, Component.Owner);
end;

procedure RegisterComponent(Instance: TComponent);
begin
  TClassRegistrator.RegisterClass(Instance);
end;

procedure CopyProps(Src: TComponent; Dst: TComponent);
var
  F: TStream;
  Reader: TReader;
  Writer: TWriter;
  NameHelper: TSetNameHelper;
  FOwner: TComponent;
begin
  F := TMemoryStream.Create;
  try
    Writer := TWriter.Create(F, 1024);
    try
      if Assigned(Src.Owner) then
        FOwner := Src.Owner else
        FOwner := Dst.Owner;
      Writer.Root := FOwner;
      Writer.WriteComponent(Src);
    finally
      Writer.Free;
    end;
    RegisterComponent(Src);
    F.Position := 0;
    Reader := TReader.Create(F, 1024);
    try
      NameHelper := TSetNameHelper.Create;
      try
        NameHelper.OldName := Dst.Name;
        Reader.Root := FOwner;
        Reader.OnSetName := NameHelper.SetName;
        Reader.BeginReferences;
        try
          Reader.ReadComponent(Dst);
          Reader.FixupReferences;
        finally
          Reader.EndReferences;
        end;
      finally
        NameHelper.Free;
      end;
    finally
      Reader.Free;
    end;
  finally
    F.Free;
  end;
end;

function CreateCloneOwner(Src: TComponent; AOwner: TComponent): TComponent;
begin
  Result := TComponentClass(Src.ClassType).Create(AOwner);
  try
    CopyProps(Src, Result);
  except
    Result.Free;
    raise;
  end;
end;

function CreateClone(Src: TComponent): TComponent;
begin
  Result := CreateCloneOwner(Src, Src.Owner)
end;

function CreateComponentOwnerNeeded(var Instance; ComponentClass: TComponentClass;
  AOwner: TComponent): TComponent;
begin
  if not Assigned(Pointer(Instance)) then
    TComponent(Instance) := ComponentClass.Create(AOwner);

  Result := TComponent(Instance);
end;

function CreateComponentNeeded(var Instance; ComponentClass: TComponentClass): TComponent;
begin
  Result := CreateComponentOwnerNeeded(Instance, ComponentClass, nil);
end;

function CreateCloneOwnerNeeded(var Instance; Src: TComponent; AOwner: TComponent): TComponent;
begin
  if not Assigned(Pointer(Instance)) then
    TComponent(Instance) := CreateCloneOwner(Src, AOwner);

  Result := TComponent(Instance)
end;

function CreateCloneNeeded(var Instance; Src: TComponent): TComponent;
begin
  Result := CreateCloneOwnerNeeded(Instance, Src, Src.Owner);
end;

procedure FreeObject(var Obj); assembler;
asm
  MOV     ECX, [EAX]
  TEST    ECX, ECX
  JE      @@exit
  PUSH    EAX
  MOV     EAX, ECX
  MOV     ECX, [EAX]