cxstorage.pas

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

        not Supports(FStoredObject, IcxStoredParent) then
        with TCollection(FStoredObject) do
          for I := 0 to Count - 1 do
            AChildren.AddObject(IntToStr(I), Items[I]);
      GetAllPublishedClassProperties(AClassProperties);
      for I := 0 to AClassProperties.Count - 1 do
      begin
        AClassProperty := GetClassProperty(AClassProperties[I]);
        if AClassProperty <> nil then
          if TestClassProperty(AClassProperties[I], AClassProperty) then
            AChildren.AddObject(AClassProperties[I], AClassProperty);
      end;
    finally
      AClassProperties.Free;
    end;
  end;
end;

function TcxStorage.GetClassProperty(const AName: string): TObject;
var
  ATypeInfo: PTypeInfo;
  APropInfo: PPropInfo;
begin
  Result := nil;
  ATypeInfo := FStoredObject.ClassInfo;
  if ATypeInfo = nil then
    Exit;
  APropInfo := GetPropInfo(ATypeInfo, AName);
  if APropInfo <> nil then
    if APropInfo^.PropType^.Kind = tkClass then
      Result := GetObjectProp(FStoredObject, APropInfo);
end;

function TcxStorage.GetComponentByName(const AName: string): TComponent;
begin
  if Assigned(FOnGetComponentByName) then
    Result := FOnGetComponentByName(AName)
  else
    Result := nil;
end;

function TcxStorage.GetObjectName(AObject: TObject): string;
var
  AInterface: IcxStoredObject;
  AObj: TObject;
begin
  if AObject <> nil then
    AObj := AObject
  else
    AObj := FStoredObject;

  if Supports(AObj, IcxStoredObject, AInterface) then
    Result := AInterface.GetObjectName
  else
    if AObj is TComponent then
      Result := (AObj as TComponent).Name
    else
      Result := 'Object';
end;

procedure TcxStorage.GetProperties(AProperties: TStrings);
var
  AInterface: IcxStoredObject;
begin
  if Supports(FStoredObject, IcxStoredObject, AInterface) then
  begin
    if not AInterface.GetProperties(AProperties) then
      GetAllPublishedProperties(AProperties);
  end
  else
    GetAllPublishedProperties(AProperties);
end;

function TcxStorage.GetPropertyValue(AName: string): Variant;

  procedure GetPropertyValueByInterface;
  var
    AInterface: IcxStoredObject;
  begin
    if Supports(FStoredObject, IcxStoredObject, AInterface) then
      AInterface.GetPropertyValue(AName, Result);
  end;

  procedure BooleanVariantToStringVariant(var AValue: Variant);
  begin
    if VarType(AValue) = varBoolean then
    begin
      if AValue then
        AValue := 'True'
      else
        AValue := 'False';
    end;
  end;

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

function TcxStorage.GetStorageModes: TcxStorageModes;
begin
  if Assigned(FOnGetStorageModes) then
    Result := FOnGetStorageModes
  else
    Result := FModes;
end;

function TcxStorage.GetUseInterfaceOnly: Boolean;
begin
  if Assigned(FOnGetUseInterfaceOnly) then
    Result := FOnGetUseInterfaceOnly
  else
    Result := FUseInterfaceOnly;
end;

procedure TcxStorage.InternalRestoreFrom(AReader: TcxCustomReader;
  const ADefaultObjectName: string);
var
  AProperties: TStringList;
  AChildrenNames: TStringList;
  AChildrenClassNames: TStringList;
  AObjectFullName: string;
  AValue: Variant;
  AIndex: Integer;
  AStorage: TcxStorage;
  AChildObject: TObject;
  AChildObjectName: string;
  AObjectName: string;
  I: Integer;
  AChildren: TStringList;
begin
  AProperties := TStringList.Create;
  AChildrenNames := TStringList.Create;
  AChildrenClassNames := TStringList.Create;
  try
    if ADefaultObjectName <> '' then
      AObjectName := ADefaultObjectName
    else
      AObjectName := GetObjectName(nil);
    if FNamePrefix <> '' then
      AObjectName := FNamePrefix + '.' + AObjectName;

    AObjectFullName := FObjectNamePrefix + AObjectName;
    AReader.ReadProperties(AObjectFullName, FStoredObject.ClassName, AProperties);
    for I := 0 to AProperties.Count - 1 do
    begin
      if AProperties[I] = '' then
        Continue;
      AValue := AReader.ReadProperty(AObjectFullName, FStoredObject.ClassName, AProperties[I]);
      if not VarIsNull(AValue) then
        SetPropertyValue(AProperties[I], AValue);
    end;

    AReader.ReadChildren(AObjectFullName, FStoredObject.ClassName, AChildrenNames, AChildrenClassNames);

    AChildren := TStringList.Create;
    try
      GetChildren(AChildren);
      CreateChildrenNames(AChildren);
      for I := 0 to AChildrenNames.Count - 1 do
      begin
        AIndex := AChildren.IndexOf(AChildrenNames[I]);
        if AIndex >= 0 then
        begin
          AChildObject := AChildren.Objects[AIndex];
          AChildObjectName := AChildren[AIndex];
          AChildren.Delete(AIndex);
        end
        else
        begin
          if smChildrenCreating in GetStorageModes then
          begin
            AChildObject := CreateChild(AChildrenNames[I], AChildrenClassNames[I]);
            AChildObjectName := AChildrenNames[I];
          end
          else
            AChildObject := nil;
        end;

        if AChildObject <> nil then
        begin
          AStorage := TcxStorage.Create('');
          AStorage.FObjectNamePrefix := AObjectFullName + '/';
          AStorage.FNamePrefix := '';
          AStorage.FStoredObject := AChildObject;
          AStorage.OnTestClassProperty := FOnTestClassProperty;
          AStorage.OnGetComponentByName := FOnGetComponentByName;
          AStorage.FModes := Modes;
          AStorage.SaveComponentPropertiesByName := FSaveComponentPropertiesByName;
          try
            AStorage.InternalRestoreFrom(AReader, AChildObjectName);
          finally
            AStorage.Free;
          end;
        end;
      end;

      if smChildrenDeleting in GetStorageModes then
      begin
        if AChildren.Count > 0 then
        begin
          for I := 0 to AChildren.Count - 1 do
            DeleteChild(AChildren[I], AChildren.Objects[I]);
        end;
      end;
    finally
      AChildren.Free;
    end;
  finally
    AProperties.Free;
    AChildrenNames.Free;
    AChildrenClassNames.Free;
  end;
end;

procedure TcxStorage.InternalStoreTo(AWriter: TcxCustomWriter; const ADefaultObjectName: string);
var
  AProperties: TStringList;
  AStorage: TcxStorage;
  I: Integer;
  AObjectFullName: string;
  AObjectName: string;
  APropertyValue: Variant;
  AChildren: TStringList;
begin
  AProperties := TStringList.Create;
  try
    if ADefaultObjectName <> '' then
      AObjectName := ADefaultObjectName
    else
      AObjectName := GetObjectName(nil);
    if FNamePrefix <> '' then
      AObjectName := FNamePrefix + '.' + AObjectName;

    AObjectFullName := FObjectNamePrefix + AObjectName;
    AWriter.BeginWriteObject(AObjectFullName, FStoredObject.ClassName);

    GetProperties(AProperties);
    for I := 0 to AProperties.Count - 1 do
    begin
      APropertyValue := GetPropertyValue(AProperties[I]);
      if not (VarIsEmpty(APropertyValue) or VarIsNull(APropertyValue)) then
        AWriter.WriteProperty(AObjectFullName, FStoredObject.ClassName, AProperties[I], APropertyValue);
    end;

    AChildren := TStringList.Create;
    try
      GetChildren(AChildren);
      for I := 0 to AChildren.Count - 1 do
      begin
        AStorage := TcxStorage.Create('');
        AStorage.FObjectNamePrefix := AObjectFullName + '/';
        AStorage.FNamePrefix := '';
        AStorage.FStoredObject := AChildren.Objects[I];
        AStorage.OnTestClassProperty := FOnTestClassProperty;
        AStorage.OnGetComponentByName := FOnGetComponentByName;
        AStorage.Modes := Modes;
        AStorage.SaveComponentPropertiesByName := FSaveComponentPropertiesByName;
        try
          AStorage.InternalStoreTo(AWriter, AChildren[I]);
        finally
          AStorage.Free;
        end;
      end;
    finally
      AChildren.Free;
    end;
    AWriter.EndWriteObject(AObjectFullName, FStoredObject.ClassName);
  finally
    AProperties.Free;
  end;
end;

procedure TcxStorage.SetPropertyValue(AName: string; AValue: Variant);

  procedure SetPropertyValueByInterface;
  var
    AInterface: IcxStoredObject;
  begin
    if Supports(FStoredObject, IcxStoredObject, AInterface) then
      AInterface.SetPropertyValue(AName, AValue);
  end;

var
  ATypeInfo: PTypeInfo;
  APropInfo: PPropInfo;
{$IFDEF DELPHI6}
  AInt64: Int64;
{$ENDIF}
  AClass: TClass;
  AComponent: TComponent;
begin
  if not VarIsNull(AValue) then
  begin
    if not GetUseInterfaceOnly then
    begin
      ATypeInfo := FStoredObject.ClassInfo;
      if ATypeInfo <> nil then
      begin
        APropInfo := GetPropInfo(ATypeInfo, AName);
        if APropInfo <> nil then
        begin
          case APropInfo^.PropType^.Kind of
            tkInteger, tkChar, tkWChar:
              SetOrdProp(FStoredObject, APropInfo, AValue);
            tkEnumeration:
              {$IFDEF DELPHI6}
              SetEnumProp(FStoredObject, APropInfo, AValue);
              {$ELSE}
              {$IFDEF DELPHI5}
              SetEnumProp(FStoredObject, AName, VarToStr(AValue));
              {$ELSE}
              SetOrdProp(FStoredObject, APropInfo, GetEnumValue(APropInfo^.PropType^, AValue));
              {$ENDIF}
              {$ENDIF}
            tkFloat:
              SetFloatProp(FStoredObject, APropInfo, AValue);
            tkString, tkLString:
              {$IFDEF DELPHI5}
              SetStrProp(FStoredObject, AName, VarToStr(AValue));
              {$ELSE}
              SetStrProp(FStoredObject, APropInfo, AValue);
              {$ENDIF}
            {$IFDEF DELPHI6}
            tkWString:
              SetWideStrProp(FStoredObject, APropInfo, AValue);
            {$ENDIF}
            tkSet:
              {$IFDEF DELPHI6}
              SetSetProp(FStoredObject, APropInfo, AValue);
              {$ELSE}
              {$IFDEF DELPHI5}
              SetSetProp(FStoredObject, AName, VarToStr(AValue));
              {$ELSE}
              SetOrdProp(FStoredObject, APropInfo, SetSetProp(APropInfo, AValue));
              {$ENDIF}
              {$ENDIF}
            tkVariant:
              SetVariantProp(FStoredObject, APropInfo, AValue);
            {$IFDEF DELPHI6}
            tkInt64:
            begin
              AInt64 := AValue;
              SetInt64Prop(FStoredObject, APropInfo, AInt64);
            end;
            {$ENDIF}
            tkClass:
            begin
              if FSaveComponentPropertiesByName then
              begin
                if VarType(AValue) = varString then
                begin
                  AClass := GetObjectPropClass(FStoredObject, APropInfo);
                  if (AClass = TComponent) or (AClass.InheritsFrom(TComponent)) then
                  begin
                    AComponent := GetComponentByName(VarToStr(AValue));
                    if AComponent <> nil then
                      SetObjectProp(FStoredObject, APropInfo, AComponent);
                  end
                  else
                    SetPropertyValueByInterface;
                end
                else
                 SetPropertyValueByInterface;
              end
              else
                SetPropertyValueByInterface;
            end;
            else
              SetPropertyValueByInterface;
          end;
        end
        else
          SetPropertyValueByInterface;
      end
      else