vgsystem.pas

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

function ReplaceComponentName(Root: TComponent; const Item, CompName: string): string;
var
  ACompName, APropName: string;
begin
  Result := '';
  if ParseStoredItem(Root, Item, ACompName, APropName) then
    Result := CreateStoredItem(CompName, APropName);
end;

function GetEnumName(TypeInfo: PTypeInfo; Value: Integer): string;
begin
  Result := TypInfo.GetEnumName(TypeInfo, Value);
end;

procedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);
var
  I: Integer;
  Component: TComponent;
  CompName, PropName: string;
begin
  if not Assigned(AStoredList) or not Assigned(AComponent) then Exit;
  AStoredList.BeginUpdate;
  try
    for I := AStoredList.Count - 1 downto 0 do
    begin
      if ParseStoredItem(AComponent, AStoredList[I], CompName, PropName) then
      begin
        if FromForm then
        begin
          Component := AComponent.FindComponent(CompName);
          if not Assigned(Component) and (CompareText(AComponent.Name, CompName) = 0) then
            Component := AComponent;
          if Assigned(Component) then
            AStoredList.Objects[I] := Component else
            AStoredList.Delete(I);
        end else begin
          Component := TComponent(AStoredList.Objects[I]);
          if Assigned(Component) then
            AStoredList[I] := ReplaceComponentName(AComponent, AStoredList[I], Component.Name) else
            AStoredList.Delete(I);
        end;
      end else
        AStoredList.Delete(I);
    end;
  finally
    AStoredList.EndUpdate;
  end;
end;

{ TTlsBuffer }
constructor TTlsBuffer.Create(ASize: Integer);
begin
  AddTlsBuffer(Self);
  FSize := ASize;
  FTlsIndex := TlsAlloc;
  if FTlsIndex < 0 then
    raise Exception.Create(LoadStr(STlsCannotAlloc));
end;

destructor TTlsBuffer.Destroy;
begin
  while Assigned(FBlocks) do FreeMemory(FBlocks[0]);
  if (FTlsIndex >= 0) then TlsFree(FTlsIndex);
  RemoveTlsBuffer(Self);
  inherited;
end;

procedure TTlsBuffer.DoDetachThreadInternal;
begin
  FreeMemory(GetTlsValue);
end;

class procedure TTlsBuffer.DoDetachThread;
var
  I: Integer;
begin
  if Assigned(FTlsBuffers) then
  begin
    EnterCriticalSection(FTlsLock);
    try
      for I := 0 to FTlsBuffers.Count - 1 do
        TTlsBuffer(FTlsBuffers.Items[I]).DoDetachThreadInternal;
    finally
      LeaveCriticalSection(FTlsLock);
    end;
  end;
end;

function TTlsBuffer.GetMemory: Pointer;
begin
  Result := GetTlsValue;
  if not Assigned(Result) then
  begin
    EnterCriticalSection(FTlsLock);
    try
      Result := AllocMemory(FSize);
      try
        ListAdd(FBlocks, Result);
      except
        FreeMemory(Result);
        raise;
      end;
    finally
      LeaveCriticalSection(FTlsLock);
    end;
    TlsSetValue(FTlsIndex, Result);
  end;
end;

function TTlsBuffer.GetTlsValue: Pointer;
begin
  Result := TlsGetValue(FTlsIndex);
end;

function TTlsBuffer.AllocMemory(ASize: Integer): Pointer;
begin
  Result := AllocMem(ASize);
end;

procedure TTlsBuffer.FreeMemory(P: Pointer);
begin
  if Assigned(P) then
  begin
    EnterCriticalSection(FTlsLock);
    try
      ListRemove(FBlocks, P);
      FreeMem(P);
    finally
      LeaveCriticalSection(FTlsLock);
    end;
  end;
end;

class procedure TTlsBuffer.AddTlsBuffer(ATlsBuffer: TTlsBuffer);
begin
  ListAdd(FTlsBuffers, ATlsBuffer);
  if FTlsBuffers.Count = 1 then
    InitializeCriticalSection(FTlsLock);
end;

class procedure TTlsBuffer.RemoveTlsBuffer(ATlsBuffer: TTlsBuffer);
begin
  ListRemove(FTlsBuffers, ATlsBuffer);
  if not Assigned(FTlsBuffers) then
    DeleteCriticalSection(FTlsLock);
end;

{ TCustomThread }
procedure TCustomThread.DoExecute;
begin
end;

procedure TCustomThread.DoHandleException(Sender: TObject);
begin
end;

procedure TCustomThread.Execute;
begin
  try
    DoExecute;
  except
    DoHandleException(Self);
  end;
end;

{ TCustomWaitThread }
constructor TCustomWaitThread.Create(CreateSuspended: Boolean; ATimeout: DWord);
begin
  inherited Create(CreateSuspended);
  FTimeout := ATimeout;
  FEvent := CreateEvent(nil, False, False, nil);
end;

destructor TCustomWaitThread.Destroy;
begin
  Reset(True);
  CloseHandle(FEvent);
  inherited
end;

procedure TCustomWaitThread.DoReset;
begin
end;

procedure TCustomWaitThread.DoTimeout;
begin
end;

procedure TCustomWaitThread.DoExecute;
begin
  while not Terminated do
    case WaitForSingleObject(FEvent, FTimeOut) of
      WAIT_OBJECT_0:
      try
        DoReset;
      except
        DoHandleException(Self);
      end;
      WAIT_TIMEOUT:
      try
        DoTimeout;
      except
        DoHandleException(Self);
      end;
    end;
end;

procedure TCustomWaitThread.Reset(TerminateThread: Boolean);
begin
  if TerminateThread then Terminate;
  if Suspended then Resume;
  SetEvent(FEvent);
end;

{ TWaitThread }
procedure TWaitThread.DoReset;
begin
  if Assigned(FOnReset) then FOnReset(Self);
end;

procedure TWaitThread.DoTimeout;
begin
  if Assigned(FOnTimeout) then FOnTimeout(Self);
end;

{ TThreadEx }
procedure TThreadEx.DoExecute;
begin
  if Assigned(FOnExecute) then FOnExecute(Self);
end;

procedure TThreadEx.DoHandleException(Sender: TObject);
begin
  if Assigned(FOnException) then FOnException(Self);
end;

{ TCustomMessageThread }
destructor TCustomMessageThread.Destroy;
begin
  WaitForQuit;
  inherited;
end;

procedure TCustomMessageThread.DoAfterMessage(const Msg: TMsg; const RetValue: Integer);
begin
end;

procedure TCustomMessageThread.DoBeforeMessage(var Msg: TMsg; var Handled: Boolean);
begin
end;

procedure TCustomMessageThread.DoExecute;
var
  Msg: TMsg;
  Handled: Boolean;
begin
  while GetMessage(Msg, 0, 0, 0) do
  begin
    DoBeforeMessage(Msg, Handled);
    if not Handled then
      DoAfterMessage(Msg, DispatchMessage(Msg));
  end;
end;

procedure TCustomMessageThread.PostMessage(Msg: UINT; wParam: WPARAM; lParam: LPARAM);
begin
  PostThreadMessage(ThreadID, Msg, wParam, lParam);
end;

procedure TCustomMessageThread.PostQuitMessage;
begin
  Self.PostMessage(WM_QUIT, 0, 0);
end;

procedure TCustomMessageThread.WaitForQuit;
begin
  if not (Terminated or Suspended) then
  begin
    PostQuitMessage;
    Terminate;
    WaitFor;
  end;
end;

{ TMessageThread }
procedure TMessageThread.DoAfterMessage(const Msg: TMsg; const RetValue: Integer);
begin
  if Assigned(FOnAfterMessage) then FOnAfterMessage(Msg, RetValue);
end;

procedure TMessageThread.DoBeforeMessage(var Msg: TMsg; var Handled: Boolean);
begin
  Handled := False;
  if Assigned(FOnBeforeMessage) then FOnBeforeMessage(Msg, Handled);
end;

{ TPropInfoList }
constructor TPropInfoList.Create(AObject: TObject; Filter: TTypeKinds);
begin
  if AObject <> nil then
  begin
    FCount := GetPropList(AObject.ClassInfo, Filter, nil);
    FSize := FCount * SizeOf(Pointer);
    GetMem(FList, FSize);
    GetPropList(AObject.ClassInfo, Filter, FList);
  end else begin
    FCount := 0;
    FList := nil;
  end;
end;

destructor TPropInfoList.Destroy;
begin
  if FList <> nil then FreeMem(FList, FSize);
end;

function TPropInfoList.Find(const AName: string): PPropInfo;
var
  I: Integer;
begin
  for I := 0 to FCount - 1 do
    with FList^[I]^ do
      if (CompareText(Name, AName) = 0) then
      begin
        Result := FList^[I];
        Exit;
      end;
  Result := nil;
end;

procedure TPropInfoList.Delete(Index: Integer);
begin
  Dec(FCount);
  if Index < FCount then Move(FList^[Index + 1], FList^[Index],
    (FCount - Index) * SizeOf(Pointer));
end;

function TPropInfoList.Get(Index: Integer): PPropInfo;
begin
  Result := FList^[Index];
end;

{$IFDEF _D4_}
{ TPropsFiler }
constructor TPropsFiler.Create(AIniFile: TCustomIniFile; const ASection: string);
begin
  FIniFile := AIniFile;
  FSection := ASection;
end;

function TPropsFiler.GetItemName(const APropName: string): string;
begin
  Result := Prefix + APropName;
end;

procedure TPropsFiler.LoadAnyProperty(PropInfo: PPropInfo);
var
  S, Def: string;
begin
  try
    if PropInfo <> nil then
    begin
      case PropInfo^.PropType^.Kind of
        tkInteger: Def := StoreIntegerProperty(PropInfo);
        tkChar: Def := StoreCharProperty(PropInfo);
        tkEnumeration: Def := StoreEnumProperty(PropInfo);
        tkFloat: Def := StoreFloatProperty(PropInfo);
        tkWChar: Def := StoreWCharProperty(PropInfo);
        tkLString: Def := StoreLStringProperty(PropInfo);
        tkVariant: Def := StoreVariantProperty(PropInfo);
        tkInt64: Def := StoreInt64Property(PropInfo);
        tkString: Def := StoreStringProperty(PropInfo);
        tkSet: Def := StoreSetProperty(PropInfo);
        tkClass: Def := '';
        else Exit;
      end;
      if (Def <> '') or (PropInfo^.PropType^.Kind in [tkString, tkClass])
        or (PropInfo^.PropType^.Kind in [tkLString,  tkWChar])
      then
        S := Trim(ReadString(Section, GetItemName(PropInfo^.Name), Def))
      else S := '';
      case PropInfo^.PropType^.Kind of
        tkInteger: LoadIntegerProperty(S, PropInfo);
        tkChar: LoadCharProperty(S, PropInfo);
        tkEnumeration: LoadEnumProperty(S, PropInfo);
        tkFloat: LoadFloatProperty(S, PropInfo);
        tkWChar: LoadWCharProperty(S, PropInfo);
        tkLString: LoadLStringProperty(S, PropInfo);
        tkVariant: LoadVariantProperty(S, PropInfo);
        tkInt64: LoadInt64Property(S, PropInfo);
        tkString: LoadStringProperty(S, PropInfo);
        tkSet: LoadSetProperty(S, PropInfo);
        tkClass: LoadClassProperty(S, PropInfo);
      end;
    end;
  except end;
end;

procedure TPropsFiler.StoreAnyProperty(PropInfo: PPropInfo);
var
  S: string;
begin
  if PropInfo <> nil then
  begin
    case PropInfo^.PropType^.Kind of
      tkInteger: S := StoreIntegerProperty(PropInfo);
      tkChar: S := StoreCharProperty(PropInfo);
      tkEnumeration: S := StoreEnumProperty(PropInfo);
      tkFloat: S := StoreFloatProperty(PropInfo);
      tkLString: S := StoreLStringProperty(PropInfo);
      tkWChar: S := StoreWCharProperty(PropInfo);
      tkVariant: S := StoreVariantProperty(PropInfo);
      tkInt64: S := StoreInt64Property(PropInfo);
      tkString: S := StoreStringProperty(PropInfo);
      tkSet: S := StoreSetProperty(PropInfo);
      tkClass: S := StoreClassProperty(PropInfo);
      else Exit;
    end;
    if (S <> '') or (PropInfo^.PropType^.Kind in [tkString
      , tkLString, tkWChar]) then
      WriteString(Section, GetItemName(PropInfo^.Name), Trim(S));
  end;
end;

function TPropsFiler.StoreIntegerProperty(PropInfo: PPropInfo): string;
begin
  Result := IntToStr(GetOrdProp(FObject, PropInfo));
end;

function TPropsFiler.StoreCharProperty(PropInfo: PPropInfo): string;
begin
  Result := Char(GetOrdProp(FObject, PropInfo));
end;

function TPropsFiler.StoreEnumProperty(PropInfo: PPropInfo): string;
begin
  Result := GetEnumName(GetPropType(PropInfo), GetOrdProp(FObject, PropInfo));
end;

function TPropsFiler.StoreFloatProperty(PropInfo: PPropInfo): string;
const
  Precisions: array[TFloatType] of Integer = (7, 15, 18, 18, 19);
begin
  Result := ReplaceStr(FloatToStrF(GetFloatProp(FObject, PropInfo), ffGeneral,
    Precisions[GetTypeData(GetPropType(PropInfo))^.FloatType], 0), 
    DecimalSeparator, '.');
end;

function TPropsFiler.StoreStringProperty(PropInfo: PPropInfo): string;
begin
  Result := GetStrProp(FObject, PropInfo);
end;

function TPropsFiler.StoreLStringProperty(PropInfo: PPropInfo): string;
begin
  Result := GetStrProp(FObject, PropInfo);
end;

function TPropsFiler.StoreWCharProperty(PropInfo: PPropInfo): string;
begin
  Result := Char(GetOrdProp(FObject, PropInfo));
end;

function TPropsFiler.StoreVariantProperty(PropInfo: PPropInfo): string;
begin
  Result := GetVariantProp(FObject, PropInfo);
end;

function TPropsFiler.StoreInt64Property(PropInfo: PPropInfo): string;
begin
  Result := IntToStr(GetInt64Prop(FObject, PropInfo));
end;

function TPropsFiler.StoreSetProperty(PropInfo: PPropInfo): string;
var
  TypeInfo: PTypeInfo;
  W: Cardinal;
  I: Integer;
begin
  Result := '[';
  W := GetOrdProp(FObject, PropInfo);
  TypeInfo := GetTypeData(GetPropType(PropInfo))^.CompType^;
  for I := 0 to SizeOf(TCardinalSet) * 8 - 1 do
    if I in TCardinalSet(W) then
    begin
      if Length(Result) <> 1 then Result := Result + ',';
      Result := Result + GetEnumName(TypeInfo, I);
    end;
  Result := Result + ']';
end;

function TPropsFiler.StoreStringsProperty(PropInfo: PPropInfo): string;
var
  List: TObject;
  I: Integer;
  SectName: string;
begin
  Result := '';
  List := TObject(GetOrdProp(Self.FObject, PropInfo));
  SectName := Format('%s.%s', [Section, GetItemName(PropInfo^.Name)]);
  EraseSection(SectName);
  if (List is TStrings) and (TStrings(List).Count > 0) then
  begin
    WriteString(SectName, sCount, IntToStr(TStrings(List).Count));
    for I := 0 to TStrings(List).Count - 1 do
      WriteString(SectName, Format(sItem, [I]), TStrings(List)[I]);
  end;
end;

function TPropsFiler.StoreComponentProperty(PropInfo: PPropInfo): string;
var
  Comp: TComponent;
  RootName: string;
begin
  Comp := TComponent(GetOrdProp(FObject, PropInfo));
  if Comp <> nil then
  begin
    Result := Comp.Name;
    if (Comp.Owner <> nil) and (Comp.Owner <> FOwner) then
    begin
      RootName := Comp.Owner.Name;
      if RootName = '' then
      begin
        RootName := Comp.Owner.ClassName;
        if (RootName <> '') and (UpCase(RootName[1]) = 'T') then
          Delete(RootName, 1, 1);
      end;
      Result := Format('%s.%s', [RootName, Result]);
    end;
  end
  else Result := sNull;
end;

function TPropsFiler.StoreClassProperty(PropInfo: PPropInfo): string;
var
  Saver: TPropsFiler;
  I: Integer;
  Obj: TObject;

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

begin
  Result := '';
  Obj := TObject(GetOrdProp(Self.FObject, PropInfo));
  if (Obj <> nil) then
  begin
    if Obj is TStrings then
      StoreStringsProperty(PropInfo)
    else if Obj is TCollection then
    begin
      EraseSection(Format('%s.%s', [Section, Prefix + PropInfo^.Name]));
      Saver := CreateStorage;
      try
        WriteString(Section, Format('%s.%s', [Prefix + PropInfo^.Name, sCount]),
          IntToStr(TCollection(Obj).Count));
        for I := 0 to TCollection(Obj).Count - 1 do