proplist.pas

类似Delphi Ide的对象查看器 可以在RUNTIME时使用

function TProperty.GetAsChar: Char;
begin
  if TypeKind in tkChars then Result:=Char(AsInteger)
  else Result:=#0;
end;

procedure TProperty.SetAsChar(const Value: Char);
begin
  if TypeKind in tkChars then AsInteger:=Ord(Value);
end;

function TProperty.GetAsBoolean: Boolean;
begin
  if Emulated and not Custom then
    if Assigned(OwnerProperty) then
      Result:=OwnerProperty.AsInteger and (1 shl Owner.IndexOf(Self)) <> 0
    else Result:=False
  else
    if TypeKind in tkOrdinals then Result:=AsInteger<>0
    else Result:=False;
end;

procedure TProperty.SetAsBoolean(const Value: Boolean);
begin
  if Emulated and not Custom then
  begin
    if Assigned(OwnerProperty) then
      if Value then
        OwnerProperty.AsInteger:=OwnerProperty.AsInteger or 1 shl Owner.IndexOf(Self)
      else
        OwnerProperty.AsInteger:=OwnerProperty.AsInteger and not (1 shl Owner.IndexOf(Self));
  end
  else
    if TypeKind in tkOrdinals then AsInteger:=Longint(Value);
end;

function TProperty.GetAsObject: TObject;
begin
  if Custom then Result:=TObject(StrToInt(GetStringValue))
  else
    if TypeKind=tkClass then Result:=TObject(GetOrdProp(Instance,FPropInfo))
    else Result:=nil;
end;

procedure TProperty.SetAsObject(const Value: TObject);
begin
  if TypeKind=tkClass then SetOrdProp(Instance,FPropInfo,Longint(Value));
end;

function TProperty.GetAsDateTime: TDateTime;
begin
  Result:=AsFloat;
end;

procedure TProperty.SetAsDateTime(const Value: TDateTime);
begin
  AsFloat:=Value;
end;

function TProperty.GetAsDate: TDate;
begin
  Result:=Int(AsFloat);
end;

procedure TProperty.SetAsDate(const Value: TDate);
begin
  AsFloat:=Int(Value);
end;

function TProperty.GetAsTime: TTime;
begin
  Result:=Frac(AsFloat);
end;

procedure TProperty.SetAsTime(const Value: TTime);
begin
  AsFloat:=Frac(Value);
end;

function TProperty.GetAsString: string;
begin
  Result:=GetStringValue;
end;

procedure TProperty.SetAsString(const Value: string);
begin
  if AsString<>Value then SetStringValue(Value);
end;

{$IFDEF VERSION3}
{$DEFINE NOGETPROPVALUE}
{$ENDIF}
{$IFDEF VERSION4}
{$DEFINE NOGETPROPVALUE}
{$ENDIF}

function TProperty.GetAsVariant: Variant;
begin
  {$IFNDEF NOGETPROPVALUE}
  Result:=GetPropValue(Instance,Name,False);
  {$ELSE}
  if TypeKind=tkVariant then Result:=GetVariantProp(Instance,FPropInfo)
  else FillChar(Result,SizeOf(Result),0);
  {$ENDIF}
end;

procedure TProperty.SetAsVariant(const Value: Variant);
begin
  if TypeKind=tkVariant then SetVariantProp(Instance,FPropInfo,Value);
end;

{$IFNDEF VERSION3}

function GetInterfaceProperty(Instance: TObject; PropInfo: PPropInfo): IUnknown;
type
  TInterfaceGetProc = function: IUnknown of object;
  TInterfaceIndexedGetProc = function(Index: Integer): IUnknown of object;
var
  P: ^IUnknown;
  M: TMethod;
  Getter: Longint;
begin
  Getter:=Longint(PropInfo^.GetProc);
  if (Getter and $FF000000)=$FF000000 then
  begin
    P:=Pointer(Integer(Instance)+(Getter and $00FFFFFF));
    Result:=P^;
  end
  else
  begin
    if (Getter and $FF000000)=$FE000000 then
      M.Code:=Pointer(PInteger(PInteger(Instance)^+SmallInt(Getter))^)
    else M.Code:=Pointer(Getter);
    M.Data:=Instance;
    if PropInfo^.Index=Integer($80000000) then Result:=TInterfaceGetProc(M)()
    else Result:=TInterfaceIndexedGetProc(M)(PropInfo^.Index);
  end;
end;

procedure SetInterfaceProperty(Instance: TObject; PropInfo: PPropInfo;
  const Value: IUnknown);
type
  TInterfaceSetProc = procedure(const Value: IUnknown) of object;
  TInterfaceIndexedSetProc = procedure (Index: Integer; const Value: IUnknown) of object;
var
  P: ^IUnknown;
  M: TMethod;
  Setter: Longint;
begin
  Setter:=Longint(PropInfo^.SetProc);
  if (Setter and $FF000000)=$FF000000 then
  begin
    P:=Pointer(Integer(Instance)+(Setter and $00FFFFFF));
    P^:=Value;
  end
  else
  begin
    if (Setter and $FF000000)=$FE000000 then
      M.Code:=Pointer(PInteger(PInteger(Instance)^+SmallInt(Setter))^)
    else M.Code:=Pointer(Setter);
    M.Data:=Instance;
    if PropInfo^.Index=Integer($80000000) then TInterfaceSetProc(M)(Value)
    else TInterfaceIndexedSetProc(M)(PropInfo^.Index,Value);
  end;
end;

function TProperty.GetAsInterface: IUnknown;
begin
  Result:=GetInterfaceProperty(Instance,FPropInfo)
end;

procedure TProperty.SetAsInterface(const Value: IUnknown);
begin
  SetInterfaceProperty(Instance,FPropInfo,Value);
end;

{$ENDIF}

constructor TProperty.Create(AOwner: TPropertyList; ARoot,AInstance: TComponent; APropInfo: PPropInfo; APropData: TCustomPropData);
begin
  inherited Create;
  FOwner:=AOwner;
  FRoot:=ARoot;
  FProperties:=CreatePropertyList;
  FProperties.FRoot:=ARoot;
  FInstance:=AInstance;
  FPropInfo:=APropInfo;
  if Emulated then FPropData:=APropData
  else FTypeData:=GetTypeData(PropType);
  if Custom then FTypeData:=GetTypeData(FPropData.PropType);
  case TypeKind of
    tkVariant: FProperties.AddEmulated(Self);
    tkSet: FProperties.AddEmulated(Self);
    tkClass:
      if not IsType(TypeInfo(TComponent)) then FProperties.Instance:=TComponent(AsObject);
  end;
end;

destructor TProperty.Destroy;
begin
  FProperties.Free;
  inherited;
end;

procedure TProperty.Assign(Source: TProperty);
begin
  FRoot:=Source.FRoot;
  FInstance:=Source.FInstance;
  FPropInfo:=Source.FPropInfo;
  FTypeData:=Source.FTypeData;
  FPropData:=Source.FPropData;
end;

function TProperty.CreatePropertyList: TPropertyList;
begin
  Result:=TPropertyList.Create(Self);
end;

function TProperty.DisplayValue: string;
begin
  if TypeKind=tkClass then
    if Assigned(AsObject) then
      if AsObject is TMenuItem then Result:='(Menu)'
      else
        if AsObject is TComponent then Result:=TComponent(AsObject).Name
        else
          if (AsObject is TGraphic) and TGraphic(AsObject).Empty or
            (AsObject is TPicture) and not Assigned(TPicture(AsObject).Graphic) then
              Result:='(None)'
          else Result:='('+AsObject.ClassName+')'
    else Result:=''
  else Result:=AsString;
end;

function TProperty.GetStringValue: string;
var
  i: Integer;
  Val: Longint;
  {$IFNDEF VERSION3}
  Obj: IUnknown;
  {$ENDIF}
begin
  if Emulated then
    if Custom then Result:=FPropData.GetProc(Instance,Self)
    else
      if Assigned(OwnerProperty) then
        case OwnerProperty.TypeKind of
          tkVariant: Result:=VariantName(TVarData(OwnerProperty.AsVariant).VType);
          tkSet: Result:=GetEnumName(TypeInfo(Boolean),Integer(AsBoolean));
        else Result:='';
        end
      else Result:=''
  else
    case TypeKind of
      tkString,tkLString,tkWString: Result:=GetStrProp(Instance,FPropInfo);
      tkChar,tkWChar: Result:=AsChar;
      tkInteger:
        if PropType=TypeInfo(TCursor) then Result:=CursorToString(AsInteger)
        else
          if PropType=TypeInfo(TColor) then Result:=ColorToString(AsInteger)
          else
            if PropType=TypeInfo(TShortCut) then
            begin
              Result:=ShortCutToText(AsInteger);
              if Result='' then Result:='(None)';
            end
            else
              if (PropType<>TypeInfo(TFontCharset)) or not CharsetToIdent(AsInteger,Result) then
                Result:=IntToStr(AsInteger);
      tkVariant:
        if VarType(AsVariant)<>varNull then
          Result:=AsVariant
        else Result:='';
      tkEnumeration: Result:=Names[AsInteger];
      tkSet:
      begin
        Result:='[';
        Val:=AsInteger;
        for i:=MinValue to MaxValue do
        begin
          if Val and 1 <> 0 then Result:=Result+GetEnumName(CompType,i)+',';
          Val:=Val shr 1;
        end;
        if Result[Length(Result)]=',' then Delete(Result,Length(Result),1);
        Result:=Result+']';
      end;
      tkFloat:
        if PropType=TypeInfo(TDateTime) then
          if AsFloat<>0 then
            Result:=DateTimeToStr(AsDateTime)
          else Result:=''
        else
          if PropType=TypeInfo(TDate) then
            if AsFloat<>0 then
              Result:=DateToStr(AsDate)
            else Result:=''
          else
            if PropType=TypeInfo(TTime) then
              if AsFloat<>0 then
                Result:=TimeToStr(AsTime)
              else Result:=''
            else Result:=FloatToStr(AsFloat);
      {$IFNDEF VERSION3}
      tkInterface:
      begin
        Result:='';
        if Assigned(Root) then
          with Root do
            for i:=0 to Pred(ComponentCount) do
            begin
              Obj:=nil;
              if (Components[i].GetInterface(GUID,Obj)) and (Obj=AsInterface) then
                Result:=Components[i].Name;
            end;
      end;
      {$ENDIF}
      tkClass:
        if IsType(TypeInfo(TComponent)) then
        begin
          if Assigned(AsObject) then Result:=TComponent(AsObject).Name
          else Result:='';
        end
        else Result:=IntToStr(Integer(AsObject));
      tkMethod:
        if Assigned(FRoot) then
          Result:=FRoot.MethodName(AsMethod.Code)
        else Result:='';
    else Result:='';
    end;
end;

procedure TProperty.SetStringValue(const Value: string);
var
  Val,Enum: string;
  P,Result,V: Integer;
  M: TMethod;
  VV: Variant;
  {$IFNDEF VERSION3}
  Comp: TComponent;
  Obj: IUnknown;
  {$ENDIF}
begin
  try
    if Emulated then
    begin
      if Custom then FPropData.SetProc(Instance,Self,Value)
      else
        if Assigned(OwnerProperty) then
          case OwnerProperty.TypeKind of
            tkVariant:
            begin
              VV:=OwnerProperty.AsVariant;
              TVarData(VV).VType:=VariantType(Value);
              OwnerProperty.AsVariant:=VV;
            end;
            tkSet: AsBoolean:=GetEnumValue(TypeInfo(Boolean),Value)<>0;
          end;
    end
    else
      case TypeKind of
        tkString,tkLString,tkWString: SetStrProp(Instance,FPropInfo,Value);
        tkChar,tkWChar:
          if Length(Value)>0 then AsChar:=Value[1]
          else AsChar:=#0;
        tkInteger:
          if PropType=TypeInfo(TCursor) then AsInteger:=StringToCursor(Value)
          else
            if PropType=TypeInfo(TColor) then AsInteger:=StringToColor(Value)
            else
              if PropType=TypeInfo(TShortCut) then AsInteger:=TextToShortCut(Value)
              else
                if (PropType=TypeInfo(TFontCharset)) and IdentToCharset(Value,Result) then
                  AsInteger:=Result
                else AsInteger:=StrToInt(Value);
        tkVariant: AsVariant:=Value;
        tkEnumeration:
        begin
          V:=Values[Value];
          if (V>=MinValue) and (V<=MaxValue) then AsInteger:=V
          else raise Exception.Create('');
        end;
        tkSet:
          if Length(Value)>2 then
          begin
            Val:=Value;
            if Val[1]='[' then Delete(Val,1,1);
            if Val[Length(Val)]=']' then Delete(Val,Length(Val),1);
            Result:=0;
            repeat
              P:=Pos(',',Val);
              if (P=0) and (Val<>'') then Enum:=Val
              else Enum:=Copy(Val,1,Pred(P));
              Delete(Val,1,P);
              V:=GetEnumValue(CompType,Enum);
              if V=0 then V:=1
              else V:=V shl 1;
              Result:=Result or V;
            until P=0;
            AsInteger:=Result;
          end;
        tkFloat:
        if PropType=TypeInfo(TDateTime) then AsDateTime:=StrToDateTime(Value)
        else
          if PropType=TypeInfo(TDate) then AsDate:=StrToDate(Value)
          else
            if PropType=TypeInfo(TTime) then AsTime:=StrToTime(Value)
            else AsFloat:=StrToFloat(Value);
        tkClass:
          if not IsType(TypeInfo(TMenuItem)) then
            if IsType(TypeInfo(TComponent)) then
            begin
              if Assigned(FRoot) then
                AsObject:=FRoot.FindComponent(Value);
            end
            else AsObject:=TObject(StrToInt(Value));
        {$IFNDEF VERSION3}
        tkInterface:
          if Assigned(FRoot) then
          begin
            Comp:=FRoot.FindComponent(Value);
            if Assigned(Comp) then
            begin
              Obj:=nil;
              if Comp.GetInterface(GUID,Obj) then AsInterface:=Obj;
            end;
          end;
        {$ENDIF}
        tkMethod:
          if Assigned(FRoot) then
          begin
            M.Code:=FRoot.MethodAddress(Value);
            M.Data:=FRoot;
            AsMethod:=M;
          end;
      end;
  except
    if GetACP=936 then
      raise EPropertyException.Create('属性值非法.')
    else if GetACP=950 then
      raise EPropertyException.Create('妮┦