cxpropertiesstore.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,012 行 · 第 1/3 页

          AChild := GetObjectProp(APersistent, APropInfo);
          if (AChild is TPersistent) and not (AChild is TComponent) then
            AChildren.AddObject(FProperties[I]{APropName}, AChild);
        end;
      end
      else
      begin
        if APersistent is TCollection then
        begin
          AChild := GetCollectionItemByName(APersistent as TCollection, APropName);
          if AChild <> nil then
            AChildren.AddObject(FProperties[I]{APropName}, AChild);
        end;
      end;
    end;
  end;
end;

function TcxPropertiesStoreComponent.GetObjectName: string;
begin
  if FComponent <> nil then
    Result := FComponent.Name
  else
    Result := '';
  if Result = '' then
    Result := 'Component' + IntToStr(Index);
end;

function TcxPropertiesStoreComponent.GetProperties(
  AProperties: TStrings): Boolean;
var
  I: Integer;
begin
  for I := 0 to FProperties.Count - 1 do
    AProperties.Add(FProperties[I]);
  Result := True;
end;

procedure TcxPropertiesStoreComponent.GetPropertyValue(const AName: string;
  var AValue: Variant);
begin
  if FComponent <> nil then
    InternalGetPropertyValue(AName, AValue)
  else
    AValue := Null;
end;

procedure TcxPropertiesStoreComponent.SetPropertyValue(const AName: string;
  const AValue: Variant);
begin
  if FComponent <> nil then
    InternalSetPropertyValue(AName, AValue);
end;

function TcxPropertiesStoreComponent.QueryInterface(const IID: TGUID;
  out Obj): HResult;
const
  E_NOINTERFACE = HResult($80004002);
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TcxPropertiesStoreComponent._AddRef: Integer;
begin
  Result := -1;
end;

function TcxPropertiesStoreComponent._Release: Integer;
begin
  Result := -1;
end;

function TcxPropertiesStoreComponent.GetPropertiesStore: TcxCustomPropertiesStore;
begin
  Result := TcxPropertiesStoreComponents(Collection).GetPropertiesStore;
end;

procedure TcxPropertiesStoreComponent.ExtractProperties;
var
  I: Integer;
  APersistent: TPersistent;
  AName: string;
begin
  FPropertiesEx.Clear;
  for I := 0 to FProperties.Count - 1 do
  begin
    APersistent := ExtractPersistentAndPropertyName(FComponent, FProperties[I], AName);
    FPropertiesEx.AddObject(AName, APersistent);
  end;
end;

function TcxPropertiesStoreComponent.ExtractPersistentAndPropertyName(
  AStartPersistent: TPersistent; const AStartName: string;
  var AResultName: string): TPersistent;

  function ExtractName(var AFName: string): string;
  var
    AIndex: Integer;
  begin
    Result := '';
    AIndex := Pos('.', AFName);
    if AIndex > 0 then
    begin
      if AIndex > 1 then
        Result := Copy(AFName, 1, AIndex - 1);
      Delete(AFName, 1, AIndex);
    end
    else
    begin
      Result := AFName;
      AFName := '';
    end;
  end;

  function GetPersistentByName(const AName: string): TPersistent;
  var
    ATypeInfo: PTypeInfo;
    APropInfo: PPropInfo;
    AObject: TObject;
  begin
    Result := nil;
    ATypeInfo := AStartPersistent.ClassInfo;
    APropInfo := GetPropInfo(ATypeInfo, AName);
    if APropInfo <> nil then
    begin
      if APropInfo^.PropType^.Kind = tkClass then
      begin
        AObject := GetObjectProp(AStartPersistent, APropInfo);
        if (AObject is TPersistent) and not (AObject is TComponent)then
          Result := AObject as TPersistent;
      end;
    end
    else
      if AStartPersistent is TCollection then
        Result := GetCollectionItemByName(AStartPersistent as TCollection, AName);
  end;
var
  AFullName: string;
  APersistent: TPersistent;
begin
  Result := nil;
  AFullName := AStartName;
  AResultName := ExtractName(AFullName);
  if AResultName <> '' then
  begin
    if AFullName = '' then
      Result := AStartPersistent
    else
    begin
      APersistent := GetPersistentByName(AResultName);
      if APersistent <> nil then
        Result := ExtractPersistentAndPropertyName(APersistent, AFullName, AResultName);
    end;
  end;
end;

function TcxPropertiesStoreComponent.GetCollectionItemByName(ACollection: TCollection;
  const AName: string): TCollectionItem;
var
  AInteger: Integer;
  ACode: Integer;
begin
  Result := nil;
  Val(AName, AInteger, ACode);
  if ACode = 0 then
    if (AInteger >= 0) and (AInteger < ACollection.Count) then
      Result := ACollection.Items[AInteger];
end;

function TcxPropertiesStoreComponent.GetPersistentAndPropertyName(
  const AStartName: string; var AResultName: string): TPersistent;

  function GetPropIndex: Integer;
  var
    I: Integer;
  begin
    Result := -1;
    for I := 0 to FProperties.Count - 1 do
      if FProperties[I] = AStartName then
      begin
        Result := I;
        Break;
      end;
  end;
var
  AIndex: Integer;
begin
  Result := nil;
  AResultName := '';
  AIndex := GetPropIndex;
  if (AIndex >= 0) and (AIndex < FProperties.Count) then
    if FPropertiesEx.Objects[AIndex] <> nil then
    begin
      Result := FPropertiesEx.Objects[AIndex] as TPersistent;
      AResultName := FPropertiesEx[AIndex];
    end;
end;

function TcxPropertiesStoreComponent.GetStorageModes: TcxStorageModes;
begin
  Result := [smChildrenCreating, smChildrenDeleting];
end;

function TcxPropertiesStoreComponent.GetComponentByName(const AName: string): TComponent;
var
  AComponent: TComponent;
begin
  Result := nil;
  AComponent := GetPropertiesStore.GetParentComponent;
  if AComponent <> nil then
    Result := AComponent.FindComponent(AName);
  if Result = nil then
  begin
    AComponent := GetPropertiesStore.Owner;
    if AComponent <> nil then
      Result := AComponent.FindComponent(AName);
  end;
end;

function TcxPropertiesStoreComponent.GetUseInterfaceOnly: Boolean;
begin
  Result := True;
end;

procedure TcxPropertiesStoreComponent.InternalGetPropertyValue(const AName: string;
  var AValue: Variant);
var
  APersistent: TPersistent;

{$IFNDEF DELPHI5}
type
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;

  function GetSetProp_(APropInfo: PPropInfo): string;
  var
    AIS: TIntegerSet;
    ATypeInfo: PTypeInfo;
    I: Integer;
  begin
    Result := '';
    Integer(AIS) := GetOrdProp(APersistent, APropInfo);
    ATypeInfo := GetTypeData(APropInfo^.PropType^)^.CompType^;
    for I := 0 to SizeOf(Integer) * 8 - 1 do
      if I in AIS then
      begin
        if Result <> '' then
          Result := Result + ',';
        if ATypeInfo^.Kind = tkInteger then
          Result := Result + IntToStr(I)
        else
          Result := Result + GetEnumName(ATypeInfo, I);
      end;
    Result := '[' + Result + ']';
  end;
{$ENDIF}

var
  ATypeInfo: PTypeInfo;
  APropInfo: PPropInfo;
  APropName: string;
  AObject: TObject;
begin
  AValue := Null;
  APersistent := GetPersistentAndPropertyName(AName, APropName);
  if (APersistent <> nil) and (APropName <> '') then
  begin
    ATypeInfo := APersistent.ClassInfo;
    if ATypeInfo <> nil then
    begin
      APropInfo := GetPropInfo(ATypeInfo, APropName);
      if APropInfo <> nil then
      begin
        case APropInfo^.PropType^.Kind of
          tkInteger, tkChar, tkWChar:
            AValue := GetOrdProp(APersistent, APropInfo);
          tkEnumeration:
            {$IFDEF DELPHI5}
            AValue := GetEnumProp(APersistent, APropInfo);
            {$ELSE}
            if APropInfo^.PropType^.Kind = tkInteger then
              AValue := IntToStr(GetOrdProp(APersistent, APropInfo))
            else
              AValue := GetEnumName(APropInfo^.PropType^, GetOrdProp(APersistent, APropInfo));
            {$ENDIF}
          tkFloat:
            AValue := GetFloatProp(APersistent, APropInfo);
          tkString, tkLString:
            AValue := GetStrProp(APersistent, APropInfo);
          {$IFDEF DELPHI6}
          tkWString:
            AValue := GetWideStrProp(APersistent, APropInfo);
          {$ENDIF}
          tkSet:
            {$IFDEF DELPHI5}
            AValue := GetSetProp(APersistent, APropInfo, True);
            {$ELSE}
            AValue := GetSetProp_(APropInfo);
            {$ENDIF}
          tkVariant:
            AValue := GetVariantProp(APersistent, APropInfo);
          {$IFDEF DELPHI6}
          tkInt64:
            AValue := GetInt64Prop(APersistent, APropInfo);
          {$ENDIF}
          tkClass:
          begin
            AObject := GetObjectProp(APersistent, APropInfo);
            if AObject = nil then
              AValue := ''
            else if AObject is TComponent then
              AValue := TComponent(AObject).Name;
          end;
        end;
      end;
    end;
  end;
end;

procedure TcxPropertiesStoreComponent.InternalSetPropertyValue(const AName: string;
  const AValue: Variant);
var
  ATypeInfo: PTypeInfo;
  APropInfo: PPropInfo;
  {$IFDEF DELPHI6}
  AInt64: Int64;
  {$ENDIF}
  APersistent: TPersistent;
  APropName: string;
  AComponent: TComponent;
  AParentComponent: TComponent;
  AOwner: TComponent;
  AComponentName: string;
begin
  if not VarIsNull(AValue) then
  begin