vgsystem.pas

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

        begin
          StoreObjectProps(TCollection(Obj).Items[I],
            Format(sItem, [I]) + sPropNameDelimiter,
            Format('%s.%s', [Section, Prefix + PropInfo^.Name]));
        end;
      finally
        Saver.Free;
      end;
    end else if Obj is TComponent then
    begin
      Result := StoreComponentProperty(PropInfo);
      Exit;
    end;
  end;
  Saver := CreateStorage;
  try
    with Saver do
      StoreObjectProps(Obj, Self.Prefix + PropInfo^.Name, Self.Section);
  finally
    Saver.Free;
  end;
end;

procedure TPropsFiler.LoadIntegerProperty(const S: string; PropInfo: PPropInfo);
begin
  SetOrdProp(FObject, PropInfo, StrToIntDef(S, 0));
end;

procedure TPropsFiler.LoadCharProperty(const S: string; PropInfo: PPropInfo);
begin
  SetOrdProp(FObject, PropInfo, Integer(S[1]));
end;

procedure TPropsFiler.LoadEnumProperty(const S: string; PropInfo: PPropInfo);
var
  I: Integer;
  EnumType: PTypeInfo;
begin
  EnumType := GetPropType(PropInfo);
  with GetTypeData(EnumType)^ do
    for I := MinValue to MaxValue do
      if CompareText(GetEnumName(EnumType, I), S) = 0 then
      begin
        SetOrdProp(FObject, PropInfo, I);
        Exit;
      end;
end;

procedure TPropsFiler.LoadFloatProperty(const S: string; PropInfo: PPropInfo);
begin
  SetFloatProp(FObject, PropInfo, StrToFloat(ReplaceStr(S, '.',
    DecimalSeparator)));
end;

procedure TPropsFiler.LoadInt64Property(const S: string; PropInfo: PPropInfo);
begin
  SetInt64Prop(FObject, PropInfo, StrToInt64Def(S, 0));
end;

procedure TPropsFiler.LoadLStringProperty(const S: string; PropInfo: PPropInfo);
begin
  SetStrProp(FObject, PropInfo, S);
end;

procedure TPropsFiler.LoadWCharProperty(const S: string; PropInfo: PPropInfo);
begin
  SetOrdProp(FObject, PropInfo, Longint(S[1]));
end;

procedure TPropsFiler.LoadVariantProperty(const S: string; PropInfo: PPropInfo);
begin
  SetVariantProp(FObject, PropInfo, S);
end;

procedure TPropsFiler.LoadStringProperty(const S: string; PropInfo: PPropInfo);
begin
  SetStrProp(FObject, PropInfo, S);
end;

procedure TPropsFiler.LoadSetProperty(const S: string; PropInfo: PPropInfo);
const
  Delims = [' ', ',', '[', ']'];
var
  TypeInfo: PTypeInfo;
  W: Cardinal;
  I, N: Integer;
  Count: Integer;
  EnumName: string;
begin
  W := 0;
  TypeInfo := GetTypeData(GetPropType(PropInfo))^.CompType^;
  Count := WordCount(S, Delims);
  for N := 1 to Count do
  begin
    EnumName := ExtractWord(N, S, Delims);
    try
      I := GetEnumValue(TypeInfo, EnumName);
      if I >= 0 then Include(TCardinalSet(W), I);
    except end;
  end;
  SetOrdProp(FObject, PropInfo, W);
end;

procedure TPropsFiler.LoadStringsProperty(const S: string; PropInfo: PPropInfo);
var
  List: TObject;
  Temp: TStrings;
  I, Cnt: Integer;
  SectName: string;
begin
  List := TObject(GetOrdProp(Self.FObject, PropInfo));
  if (List is TStrings) then
  begin
    SectName := Format('%s.%s', [Section, GetItemName(PropInfo^.Name)]);
    Cnt := StrToIntDef(Trim(ReadString(SectName, sCount, '0')), 0);
    if Cnt > 0 then
    begin
      Temp := TStringList.Create;
      try
        for I := 0 to Cnt - 1 do
          Temp.Add(ReadString(SectName, Format(sItem, [I]), ''));
        TStrings(List).Assign(Temp);
      finally
        Temp.Free;
      end;
    end;
  end;
end;

procedure TPropsFiler.LoadComponentProperty(const S: string; PropInfo: PPropInfo);
var
  RootName, Name: string;
  Root: TComponent;
  P: Integer;
begin
  if Trim(S) = '' then Exit;
  if CompareText(SNull, Trim(S)) = 0 then
  begin
    SetOrdProp(FObject, PropInfo, Longint(nil));
    Exit;
  end;
  P := Pos('.', S);
  if P > 0 then
  begin
    RootName := Trim(Copy(S, 1, P - 1));
    Name := Trim(Copy(S, P + 1, MaxInt));
  end else begin
    RootName := '';
    Name := Trim(S);
  end;
  if RootName <> '' then
    Root := FindGlobalComponent(RootName)
  else Root := FOwner;
  if (Root <> nil) then
    SetOrdProp(FObject, PropInfo, Longint(Root.FindComponent(Name)));
end;

procedure TPropsFiler.LoadClassProperty(const S: string; PropInfo: PPropInfo);
var
  Loader: TPropsFiler;
  I: Integer;
  Cnt: Integer;
  Recreate: Boolean;
  Obj: TObject;

  procedure LoadObjectProps(Obj: TObject; const APrefix, ASection: string);
  var
    I: Integer;
    Props: TPropInfoList;
  begin
    with Loader do
    begin
      AObject := Obj;
      Prefix := APrefix;
      Props := TPropInfoList.Create(AObject, tkProperties);
      try
        for I := 0 to Props.Count - 1 do LoadAnyProperty(Props.Items[I]);
      finally
        Props.Free;
      end;
    end;
  end;

begin
  Obj := TObject(GetOrdProp(Self.FObject, PropInfo));
  if (Obj <> nil) then
  begin
    if Obj is TStrings then
      LoadStringsProperty(S, PropInfo)
    else if Obj is TCollection then
    begin
      Loader := CreateStorage;
      try
        Cnt := TCollection(Obj).Count;
        Cnt := StrToIntDef(ReadString(Section, Format('%s.%s',
          [Prefix + PropInfo^.Name, sCount]), IntToStr(Cnt)), Cnt);
        Recreate := TCollection(Obj).Count <> Cnt;
        TCollection(Obj).BeginUpdate;
        try
          if Recreate then TCollection(Obj).Clear;
          for I := 0 to Cnt - 1 do
          begin
            if Recreate then TCollection(Obj).Add;
            LoadObjectProps(TCollection(Obj).Items[I],
              Format(sItem, [I]) + sPropNameDelimiter,
              Format('%s.%s', [Section, Prefix + PropInfo^.Name]));
          end;
        finally
          TCollection(Obj).EndUpdate;
        end;
      finally
        Loader.Free;
      end;
    end else if Obj is TComponent then
    begin
      LoadComponentProperty(S, PropInfo);
      Exit;
    end;
  end;
  Loader := CreateStorage;
  try
    LoadObjectProps(Obj, Self.Prefix + PropInfo^.Name, Self.Section);
  finally
    Loader.Free;
  end;
end;

procedure TPropsFiler.StoreProperties(PropList: TStrings);
var
  I: Integer;
  Props: TPropInfoList;
begin
  Props := TPropInfoList.Create(AObject, tkProperties);
  try
    for I := 0 to PropList.Count - 1 do
      StoreAnyProperty(Props.Find(PropList[I]));
  finally
    Props.Free;
  end;
end;

procedure TPropsFiler.LoadProperties(PropList: TStrings);
var
  I: Integer;
  Props: TPropInfoList;
begin
  Props := TPropInfoList.Create(AObject, tkProperties);
  try
    for I := 0 to PropList.Count - 1 do
      LoadAnyProperty(Props.Find(PropList[I]));
  finally
    Props.Free;
  end;
end;

function TPropsFiler.CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;
var
  I: Integer;
  Obj: TComponent;
  Props: TPropInfoList;
begin
  UpdateStoredList(AComponent, StoredList, False);
  Result := TStringList.Create;
  try
    TStringList(Result).Sorted := True;
    for I := 0 to StoredList.Count - 1 do
    begin
      Obj := TComponent(StoredList.Objects[I]);
      if Result.IndexOf(Obj.Name) < 0 then
      begin
        Props := TPropInfoList.Create(Obj, tkProperties);
        try
          Result.AddObject(Obj.Name, Props);
        except
          Props.Free;
          raise;
        end;
      end;
    end;
  except
    Result.Free;
    Result := nil;
  end;
end;

procedure TPropsFiler.FreeInfoLists(Info: TStrings);
var
  I: Integer;
begin
  for I := Info.Count - 1 downto 0 do
    Info.Objects[I].Free;
  Info.Free;
end;

procedure TPropsFiler.LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);
var
  Info: TStrings;
  I, Idx: Integer;
  Props: TPropInfoList;
  CompName, PropName: string;
begin
  Info := CreateInfoList(AComponent, StoredList);
  if Info <> nil then
  try
    FOwner := AComponent;
    for I := 0 to StoredList.Count - 1 do
    begin
      if ParseStoredItem(AComponent, StoredList[I], CompName, PropName) then
      begin
        AObject := StoredList.Objects[I];
        Prefix := TComponent(AObject).Name;
        Idx := Info.IndexOf(Prefix);
        if Idx >= 0 then
        begin
          Prefix := Prefix + sPropNameDelimiter;
          Props := TPropInfoList(Info.Objects[Idx]);
          if Props <> nil then LoadAnyProperty(Props.Find(PropName));
        end;
      end;
    end;
  finally
    FOwner := nil;
    FreeInfoLists(Info);
  end;
end;

procedure TPropsFiler.StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);
var
  Info: TStrings;
  I, Idx: Integer;
  Props: TPropInfoList;
  CompName, PropName: string;
begin
  Info := CreateInfoList(AComponent, StoredList);
  if Info <> nil then
  try
    FOwner := AComponent;
    for I := 0 to StoredList.Count - 1 do
    begin
      if ParseStoredItem(AComponent, StoredList[I], CompName, PropName) then
      begin
        AObject := StoredList.Objects[I];
        Prefix := TComponent(AObject).Name;
        Idx := Info.IndexOf(Prefix);
        if Idx >= 0 then
        begin
          Prefix := Prefix + sPropNameDelimiter;
          Props := TPropInfoList(Info.Objects[Idx]);
          if Props <> nil then StoreAnyProperty(Props.Find(PropName));
        end;
      end;
    end;
  finally
    FOwner := nil;
    FreeInfoLists(Info);
  end;
end;

function TPropsFiler.CreateStorage: TPropsFiler;
begin
  Result := TPropsFiler.Create(FIniFile, FSection);
end;

function TPropsFiler.ReadString(const ASection, Item, Default: string): string;
begin
  Result := FIniFile.ReadString(ASection, Item, Default);
end;

procedure TPropsFiler.WriteString(const ASection, Item, Value: string);
begin
  FIniFile.WriteString(ASection, Item, Value);
end;

procedure TPropsFiler.EraseSection(const ASection: string);
begin
  FIniFile.EraseSection(ASection);
end;
{$ENDIF}

{ TvgThreadList }
constructor TvgThreadList.Create;
begin
{$IFDEF _D4_}
  FLock := TMultiReadExclusiveWriteSynchronizer.Create;
{$ELSE}
  InitializeCriticalSection(FLock);
{$ENDIF}
end;

destructor TvgThreadList.Destroy;
begin
  Clear;
{$IFDEF _D4_}
  FLock.Free;
{$ELSE}
  DeleteCriticalSection(FLock);
{$ENDIF}
  inherited;
end;

function TvgThreadList.GetCount: Integer;
begin
  BeginRead;
  try
    Result := ListCount(FItems);
  finally
    EndRead;
  end;
end;

function TvgThreadList.GetItem(Index: Integer): Pointer;
begin
  BeginRead;
  try
    Result := ListItem(FItems, Index);
  finally
    EndRead;
  end;
end;

function TvgThreadList.IndexOf(Item: Pointer): Integer;
begin
  BeginRead;
  try
    Result := ListIndexOf(FItems, Item);
  finally
    EndRead;
  end;
end;

procedure TvgThreadList.BeginRead;
begin
{$IFDEF _D4_}
  FLock.BeginRead;
{$ELSE}
  EnterCriticalSection(FLock);
{$ENDIF}
end;

procedure TvgThreadList.EndRead;
begin
{$IFDEF _D4_}
  FLock.EndRead;
{$ELSE}
  LeaveCriticalSection(FLock);
{$ENDIF}
end;

procedure TvgThreadList.BeginWrite;
begin
{$IFDEF _D4_}
  FLock.BeginWrite;
{$ELSE}
  EnterCriticalSection(FLock);
{$ENDIF}
end;

procedure TvgThreadList.EndWrite;
begin
{$IFDEF _D4_}
  FLock.EndWrite;
{$ELSE}
  LeaveCriticalSection(FLock);
{$ENDIF}
end;

procedure TvgThreadList.Lock;
begin
  BeginWrite;
end;

procedure TvgThreadList.Unlock;
begin
  EndWrite;
end;

function TvgThreadList.Add(Item: Pointer): Integer;
begin
  BeginWrite;
  try
    Result := Count;
    Insert(Result, Item);
  finally
    EndWrite;
  end;
end;

procedure TvgThreadList.Insert(Index: Integer; Item: Pointer);
begin
  BeginWrite;
  try
    ListInsert(FItems, Index, Item);
  finally
    EndWrite;
  end;
end;

procedure TvgThreadList.Clear;
begin
  BeginWrite;
  try
    ListClear(FItems);
  finally
    EndWrite;
  end;
end;

procedure TvgThreadList.Remove(Item: Pointer);
begin
  BeginWrite;
  try
    if ListIndexOf(FItems, Item) >= 0 then
      ListRemove(FItems, Item);
  finally
    EndWrite;
  end;
end;

var
  FCompressorList: TObject = nil;

function CompressorList: TCompressorList;
begin
  if not Assigned(FCompressorList) then FCompressorList := TCompressorList.Create;
  Result := TCompressorList(FCompressorList);
end;

procedure Compress(Sign: TSignature; Stream: TStream; const Buff; Count: Integer; Data: Pointer);
var
  Compressor: TCompressor;
begin
  Compressor := CompressorList.CreateCompressor(Sign);
  try
    Compressor.Compress(Stream, Buff, Count, Data);
  finally
    Compressor.Free;
  end;
end;

procedure UnCompress(Sign: TSignature; Stream: TStream; const Buff; Count: Integer; Data: Pointer);
var
  Compressor: TCompressor;
begin
  Compressor := CompressorList.CreateCompressor(Sign);
  try
    Compressor.UnCompress(Stream, Buff, Count, Data);
  finally
    Compressor.Free;
  end;
end;

{ TCompressor }
constructor TCompressor.Create;
begin
end;

class function TCompressor.Sign: TSignature;
begin
  Result := (#0#0#0#0);
end;

procedure TCompressor.Compress(AStream: TStream; const ABuff; ACount: Integer; AData: Pointer);
begin
  FStream := AStream;
  FBuff := @ABuff;
  FBuffSize := ACount;
  FData := AData;
end;

procedure TCompressor.UnCompress(AStream: TStream; const ABuff; ACount: Integer; AData: Pointer);
begin
  FStream := AStream;