cdibanimcontainer.pas

Delphi控件

procedure AddPropertyMorpher(ATypeInfo: PTypeInfo; MorpherProc: PDIBPropertyMorpher;
  UnitName: string);
procedure RequiredUnits(Result: TStrings);

implementation

const
  cMaxAnimSpeed = 50;

  cSupportedProperties: TTypeKinds =
    [tkInteger, tkChar, tkFloat, tkString, tkWChar, tkLString, tkWString,
    tkInt64];

type
  TDIBPropertyMap = class
  private
    FPropertyMorpherList: TList;
    FTypeInfoList: TStringList;
    FUnitNames: TStringList;
  protected
  public
    constructor Create;
    destructor Destroy; override;

    procedure AddPropertyMorpher(ATypeInfo: PTypeInfo; MorpherProc: PDIBPropertyMorpher;
      UnitName: string);
    function MorphPropertyValue(Instance: TComponent; const PropName: string;
      StartValue, EndValue: Variant; Position: Byte): Variant;
  published
  end;

var
  DIBPropertyMap: TDIBPropertyMap;

procedure RequiredUnits(Result: TStrings);
begin
  if Result <> nil then Result.Assign(DIBPropertyMap.FUnitNames);
end;

procedure AddPropertyMorpher(ATypeInfo: PTypeInfo;
  MorpherProc: PDIBPropertyMorpher; UnitName: string);
begin
  DIBPropertyMap.AddPropertyMorpher(ATypeInfo, MorpherProc, UnitName);
end;

function MorphAngle(Info: PTypeInfo; StartValue, EndValue: Variant;
  Position: Byte): Variant;
begin
  if (StartValue + 359) - EndValue <= Abs(EndValue - StartValue) then
    StartValue := StartValue + 359;

  Result := StartValue + ((EndValue - StartValue) * Position div 255);
  if Result > 359 then Result := Result - 359;
end;

function MorphInteger(Info: PTypeInfo; StartValue, EndValue: Variant;
  Position: Byte): Variant;
begin
  Result := StartValue + ((EndValue - StartValue) * Position div 255);
end;

function MorphExtended(Info: PTypeInfo; StartValue, EndValue: Variant;
  Position: Byte): Variant;
begin
  Result := StartValue + ((EndValue - StartValue) * Position / 255);
end;


function MorphColor(Info: PTypeInfo; StartValue, EndValue: Variant;
  Position: Byte): Variant;
var
  SourceCol, DestCol, ResultCol: TColor;
  I: Integer;
  SourceBytes, DestBytes, ResultBytes: PByteArray;
begin
  SourceCol := ColorToRGB(StartValue);
  DestCol := ColorToRGB(EndValue);
  SourceBytes := @SourceCol;
  DestBytes := @DestCol;
  ResultBytes := @ResultCol;
  for I := 0 to 3 do
    ResultBytes[I] := SourceBytes[I] + (DestBytes[I] - SourceBytes[I]) * Position div 255;
  Result := ResultCol;
end;

{ TDIBPropertyMap }

procedure TDIBPropertyMap.AddPropertyMorpher(ATypeInfo: PTypeInfo;
  MorpherProc: PDIBPropertyMorpher; UnitName: string);
begin
  if FTypeInfoList.Count = 0 then
  begin
    FTypeInfoList.Add(ATypeInfo^.Name);
    FPropertyMorpherList.Add(MorpherProc);
  end 
  else
  begin
    FTypeInfoList.Insert(0, ATypeInfo^.Name);
    FPropertyMorpherList.Insert(0, MorpherProc);
  end;
  if (UnitName <> '') and (FUnitNames.IndexOf(UnitName) < 0) then
    FUnitNames.Add(UnitName);
end;

constructor TDIBPropertyMap.Create;
begin
  FPropertyMorpherList := TList.Create;
  FTypeInfoList := TStringList.Create;
  FUnitNames := TStringList.Create;
end;

destructor TDIBPropertyMap.Destroy;
begin
  FUnitNames.Free;
  FPropertyMorpherList.Free;
  FTypeInfoList.Free;
  inherited;
end;

function TDIBPropertyMap.MorphPropertyValue(Instance: TComponent;
  const PropName: string; StartValue, EndValue: Variant; Position: Byte): Variant;
var
  PInfo: PPropInfo;
  Index: Integer;
  FProc: TDIBPropertyMorpher;
begin
  if Position > 128 then
    Result := EndValue
  else
    Result := StartValue;

  PInfo := GetPropInfo(Instance, PropName, cSupportedProperties);
  Index := FTypeInfoList.IndexOf(PInfo.PropType^.Name);
  if Index >= 0 then
  begin
    FProc := TDIBPropertyMorpher(FPropertyMorpherList[Index]);
    if Assigned(FProc) then
      Result := FProc(PInfo.PropType^, StartValue, EndValue, Position);
  end;
end;
(*
var
  PInfo: PPropInfo;
  Index: Integer;
  FProc: TDIBPropertyMorpher;
  NewValue: Variant;
begin
  PInfo := GetPropInfo(Instance, PropName, cSupportedProperties);
  Index := FTypeInfoList.IndexOf(PInfo.PropType^.Name);
  if Index >= 0 then
  begin
    FProc := TDIBPropertyMorpher(FPropertyMorpherList[Index]);
    if Assigned(FProc) then
    begin
      NewValue := FProc(PInfo.PropType^, StartValue, EndValue, Position);
      if GetPropValue(Instance, PropName) <> NewValue then
        SetPropValue(Instance, PropName, NewValue);
    end;
  end;

end;
*)

{ TDIBControlProperty }

procedure TDIBControlProperty.AssignTo(Dest: TPersistent);
begin
  if Dest is TDIBControlProperty then with TDIBControlProperty(Dest) do
    begin
      PropName := Self.PropName;
      Value := Self.Value;
    end;
end;

constructor TDIBControlProperty.Create(Collection: TCollection);
begin
  inherited;
  if Collection <> nil then
    Owner := TDIBControlProperties(Collection).Owner;
end;

destructor TDIBControlProperty.Destroy;
begin
  inherited;
end;

{ TDIBControlProperties }

function TDIBControlProperties.Add: TDIBControlProperty;
begin
  Result := TDIBControlProperty(inherited Add);
end;

constructor TDIBControlProperties.Create(AOwner: TComponent);
begin
  inherited Create(AOwner, TDIBControlProperty);
  Owner := AOwner;
end;

destructor TDIBControlProperties.Destroy;
begin
  inherited;
end;

function TDIBControlProperties.GetItem(Index: Integer): TDIBControlProperty;
begin
  Result := TDIBControlProperty(inherited GetItem(Index));
end;

function TDIBControlProperties.Insert(Index: Integer): TDIBControlProperty;
begin
  Result := TDIBControlProperty(inherited Insert(Index));
end;

procedure TDIBControlProperties.MakeSnapShot(const Control: TControl);
var
  I, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
  Prop: TDIBControlProperty;
begin
  Clear;

  Count := GetTypeData(Control.ClassInfo).PropCount;
  if Count > 0 then
  begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(Control.ClassInfo, PropList);
      for I := 0 to Count - 1 do
      begin
        PropInfo := PropList[I];
        if (PropInfo^.PropType^.Kind in cSupportedProperties) and
          (DIBPropertyMap.FTypeInfoList.IndexOf(PropInfo^.PropType^.Name) >= 0) then
        begin
          if (CompareText(PropInfo^.Name, 'Name') <> 0) and
            (CompareText(PropInfo^.Name, 'Tag') <> 0) and
            (PropInfo^.Name <> '') then
          begin
            Prop := Add;
            Prop.PropName := PropInfo^.Name;
            case PropInfo^.PropType^.Kind of
              tkChar, tkInteger:
                Prop.Value := IntToStr(GetOrdProp(Control, Prop.PropName));
              tkInt64:
                Prop.Value := IntToStr(GetInt64Prop(Control, Prop.PropName));
              tkString, tkWChar, tkLString, tkWString:
                Prop.Value := GetStrProp(Control, Prop.PropName);
              tkFloat:
                Prop.Value := FloatToStr(GetFloatProp(Control, Prop.PropName));
            end;
          end;
        end;
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;
end;

procedure TDIBControlProperties.SetItem(Index: Integer;
  const Value: TDIBControlProperty);
begin
  inherited SetItem(Index, Value);
end;

{ TDIBSnapShotControl }

procedure TDIBSnapShotControl.AssignTo(Dest: TPersistent);
begin
  if Dest is TDIBSnapShotControl then with TDIBSnapShotControl(Dest) do
    begin
      Control := Self.Control;
      Properties.Assign(Self.Properties);
    end 
  else
    inherited;
end;

constructor TDIBSnapShotControl.Create(Collection: TCollection);
begin
  inherited;
  if Collection <> nil then
    Owner := TDIBSnapShotControls(Collection).Owner;
  FProperties := TDIBControlProperties.Create(Owner);
end;

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

function TDIBSnapShotControl.FindProperty(const PropName: string): TDIBControlProperty;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to Properties.Count - 1 do
    if CompareText(PropName, Properties[I].PropName) = 0 then
    begin
      Result := Properties[I];
      Break;
    end;
end;

procedure TDIBSnapShotControl.MakeSnapShot;
begin
  Properties.MakeSnapShot(Control);
  if (Control is TWinControl) and not (Control is TCustomDIBAnimContainer) then
    with TWinControl(Control) do
      Self.Properties.MakeSnapShot(Control);
  if (Properties.Count = 0) then Free;
end;

procedure TDIBSnapShotControl.MorphTo(Dest: TDIBSnapShotControl; Position: Byte);
var
  I: Integer;
  DestProp: TDIBControlProperty;
  NewValue: Variant;
  BR: TRect;
begin
  BR := Control.BoundsRect;
  for I := 0 to Properties.Count - 1 do
  begin
    DestProp := Dest.FindProperty(Properties[I].PropName);
    if DestProp <> nil then with Properties[I] do
      begin
        NewValue := DIBPropertyMap.MorphPropertyValue(Control, PropName,
          Value, DestProp.Value, Position);
        if CompareText(PropName, 'LEFT') = 0 then
        begin
          BR.Left := NewValue;
          BR.Right := BR.Right + NewValue;
        end 
        else if CompareText(PropName, 'TOP') = 0 then
        begin
          BR.Top := NewValue;
          BR.Bottom := BR.Bottom + NewValue;
        end 
        else if CompareText(PropName, 'WIDTH') = 0 then
          BR.Right := BR.Left + NewValue
        else if CompareText(PropName, 'HEIGHT') = 0 then
          BR.Bottom := BR.Top + NewValue
        else if GetPropValue(Control, PropName) <> NewValue then
          SetPropValue(Control, PropName, NewValue);
      end;
  end;

  with Control.BoundsRect do
    if (BR.Left <> Left) or (BR.Right <> Right) or (BR.Right <> Right) or
      (BR.Bottom <> Bottom) then
      case Control.Align of
        alNone: Control.BoundsRect := BR;
        alTop: Control.Height := BR.Bottom - BR.Top;
        alLeft: Control.Width := BR.Right - BR.Left;
        alRight: with Control do BoundsRect := Rect(BR.Left, Top, BR.Right, Top + Height);
        alBottom: with Control do BoundsRect := Rect(Left, BR.Top, Left + Width, BR.Bottom);
      end;


  if (Control <> Owner) and (Control is TWinControl) then Control.Repaint;
end;

procedure TDIBSnapShotControl.SetControl(const Value: TControl);
begin
  if Value <> Control then
  begin
    if Assigned(FControl) then
      FControl.RemoveFreeNotification(Owner);
    FControl := Value;
    if Assigned(FControl) then
      FControl.FreeNotification(Owner);
  end;
end;

procedure TDIBSnapShotControl.SetProperties(const Value: TDIBControlProperties);
begin
  FProperties.Assign(Value);
end;

{ TDIBSnapShotControls }

function TDIBSnapShotControls.Add: TDIBSnapShotControl;
begin
  Result := TDIBSnapShotControl(inherited Add);
end;

constructor TDIBSnapShotControls.Create(AOwner: TComponent);
begin
  inherited Create(Owner, TDIBSnapShotControl);