designeditors.pas

关于USB的一段源码,大家可以试下,第一次上传

  begin
    Result := Designer.GetObjectName(GetComponent(0));
    for I := Length(Result) downto 1 do
      if Result[I] in ['.', '[', ']', '-', '>'] then
        Delete(Result, I, 1);
  end;
  if Result = '' then
    raise EPropertyError.CreateRes(@SCannotCreateName);
  Result := Result + GetTrimmedEventName;
end;

function TMethodProperty.GetTrimmedEventName: string;
begin
  Result := GetName;
  if (Length(Result) >= 2) and
    (Result[1] in ['O', 'o']) and (Result[2] in ['N', 'n']) then
    Delete(Result,1,2);
end;

function TMethodProperty.GetValue: string;
begin
  Result := Designer.GetMethodName(GetMethodValue);
end;

procedure TMethodProperty.GetValues(Proc: TGetStrProc);
begin
  Designer.GetMethods(GetTypeData(GetPropType), Proc);
end;

procedure TMethodProperty.SetValue(const AValue: string);

  procedure CheckChainCall(const MethodName: string; Method: TMethod);
  var
    Persistent: TPersistent;
    Component: TComponent;
    InstanceMethod: string;
    Instance: TComponent;
  begin
    Persistent := GetComponent(0);
    if Persistent is TComponent then
    begin
      Component := TComponent(Persistent);
      if (Component.Name <> '') and (Method.Data <> Designer.GetRoot) and
        (TObject(Method.Data) is TComponent) then
      begin
        Instance := TComponent(Method.Data);
        InstanceMethod := Instance.MethodName(Method.Code);
        if InstanceMethod <> '' then
          Designer.ChainCall(MethodName, Instance.Name, InstanceMethod,
            GetTypeData(GetPropType));
      end;
    end;
  end;

var
  NewMethod: Boolean;
  CurValue: string;
  OldMethod: TMethod;
begin
  if not AllNamed then
    raise EPropertyError.CreateRes(@SCannotCreateName);
  CurValue:= GetValue;
  if (CurValue <> '') and (AValue <> '') and (SameText(CurValue, AValue) or
    not Designer.MethodExists(AValue)) and not Designer.MethodFromAncestor(GetMethodValue) then
    Designer.RenameMethod(CurValue, AValue)
  else
  begin
    NewMethod := (AValue <> '') and not Designer.MethodExists(AValue);
    OldMethod := GetMethodValue;
    SetMethodValue(Designer.CreateMethod(AValue, GetTypeData(GetPropType)));
    if NewMethod then
    begin
      if (PropCount = 1) and (OldMethod.Data <> nil) and (OldMethod.Code <> nil) then
        CheckChainCall(AValue, OldMethod);
      Designer.ShowMethod(AValue);
    end;
  end;
end;

{ TDateProperty }

function TDateProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paRevertable];
end;

function TDateProperty.GetValue: string;
var
  DT: TDateTime;
begin
  DT := GetFloatValue;
  if DT = 0.0 then Result := '' else
  Result := DateToStr(DT);
end;

procedure TDateProperty.SetValue(const Value: string);
var
  DT: TDateTime;
begin
  if Value = '' then DT := 0.0
  else DT := StrToDate(Value);
  SetFloatValue(DT);
end;

{ TTimeProperty }

function TTimeProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paRevertable];
end;

function TTimeProperty.GetValue: string;
var
  DT: TDateTime;
begin
  DT := GetFloatValue;
  if DT = 0.0 then Result := '' else
  Result := TimeToStr(DT);
end;

procedure TTimeProperty.SetValue(const Value: string);
var
  DT: TDateTime;
begin
  if Value = '' then DT := 0.0
  else DT := StrToTime(Value);
  SetFloatValue(DT);
end;

{ TDateTimeProperty }

function TDateTimeProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paRevertable];
end;

function TDateTimeProperty.GetValue: string;
var
  DT: TDateTime;
begin
  DT := GetFloatValue;
  if DT = 0.0 then Result := '' else
  Result := DateTimeToStr(DT);
end;

procedure TDateTimeProperty.SetValue(const Value: string);
var
  DT: TDateTime;
begin
  if Value = '' then DT := 0.0
  else DT := StrToDateTime(Value);
  SetFloatValue(DT);
end;

{ TPropInfoList }

type
  TPropInfoList = class
  private
    FList: PPropList;
    FCount: Integer;
    FSize: Integer;
    function Get(Index: Integer): PPropInfo;
  public
    constructor Create(Instance: TPersistent; Filter: TTypeKinds);
    destructor Destroy; override;
    function Contains(P: PPropInfo): Boolean;
    procedure Delete(Index: Integer);
    procedure Intersect(List: TPropInfoList);
    property Count: Integer read FCount;
    property Items[Index: Integer]: PPropInfo read Get; default;
  end;

constructor TPropInfoList.Create(Instance: TPersistent; Filter: TTypeKinds);
begin
  FCount := GetPropList(Instance.ClassInfo, Filter, nil);
  FSize := FCount * SizeOf(Pointer);
  GetMem(FList, FSize);
  GetPropList(Instance.ClassInfo, Filter, FList);
end;

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

function TPropInfoList.Contains(P: PPropInfo): Boolean;
var
  I: Integer;
begin
  for I := 0 to FCount - 1 do
    with FList^[I]^ do
      if (PropType^ = P^.PropType^) and (CompareText(Name, P^.Name) = 0) then
      begin
        Result := True;
        Exit;
      end;
  Result := False;
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;

procedure TPropInfoList.Intersect(List: TPropInfoList);
var
  I: Integer;
begin
  for I := FCount - 1 downto 0 do
    if not List.Contains(FList^[I]) then Delete(I);
end;

function InterfaceInheritsFrom(Child, Parent: PTypeData): Boolean;
begin
  while (Child <> nil) and (Child <> Parent) and (Child^.IntfParent <> nil) do
    Child := GetTypeData(Child^.IntfParent^);
  Result := (Child <> nil) and (Child = Parent);
end;

{ Property Editor registration }

type
  PPropertyClassRec = ^TPropertyClassRec;
  TPropertyClassRec = record
    Group: Integer;
    PropertyType: PTypeInfo;
    PropertyName: string;
    ComponentClass: TClass;
    ClassGroup: TPersistentClass;
    EditorClass: TPropertyEditorClass;
  end;

  PPropertyMapperRec = ^TPropertyMapperRec;
  TPropertyMapperRec = record
    Group: Integer;
    Mapper: TPropertyMapperFunc;
  end;

const
  PropClassMap: array[TypInfo.TTypeKind] of TPropertyEditorClass = (
    nil,                // tkUnknown
    TIntegerProperty,   // tkInteger
    TCharProperty,      // tkChar
    TEnumProperty,      // tkEnumeration
    TFloatProperty,     // tkFloat
    TStringProperty,    // tkString
    TSetProperty,       // tkSet
    TClassProperty,     // tkClass
    TMethodProperty,    // tkMethod
    TPropertyEditor,    // tkWChar
    TStringProperty,    // tkLString
    TStringProperty,    // tkWString
    TVariantProperty,   // tkVariant
    nil,                // tkArray
    nil,                // tkRecord
    TInterfaceProperty, // tkInterface
    TInt64Property,     // tkInt64
    nil);               // tkDynArray

var
  PropertyClassList: TList;
  PropertyMapperList: TList = nil;

procedure RegisterPropertyEditor(PropertyType: PTypeInfo; ComponentClass: TClass;
  const PropertyName: string; EditorClass: TPropertyEditorClass);
var
  P: PPropertyClassRec;
begin
  if PropertyClassList = nil then
    PropertyClassList := TList.Create;
  New(P);
  P.Group := CurrentGroup;
  P.PropertyType := PropertyType;
  P.ComponentClass := ComponentClass;
  P.PropertyName := '';
  P.ClassGroup := nil;
  if Assigned(ComponentClass) then P^.PropertyName := PropertyName;
  P.EditorClass := EditorClass;
  PropertyClassList.Insert(0, P);
end;

procedure SetPropertyEditorGroup(EditorClass: TPropertyEditorClass;
  GroupClass: TPersistentClass);
var
  P: PPropertyClassRec;
  I: Integer;
begin
  for I := 0 to PropertyClassList.Count - 1 do
  begin
    P := PropertyClassList[I];
    if P^.EditorClass = EditorClass then
    begin
      P^.ClassGroup := ClassGroupOf(GroupClass);
      Exit;
    end;
  end;
  // Ignore it if the EditorClass is not found.
end;

function GetEditorClass(PropInfo: PPropInfo;
  Obj: TPersistent): TPropertyEditorClass;
var
  PropType: PTypeInfo;
  P, C: PPropertyClassRec;
  I: Integer;
begin
  if PropertyMapperList <> nil then
  begin
    for I := 0 to PropertyMapperList.Count -1 do
      with PPropertyMapperRec(PropertyMapperList[I])^ do
      begin
        Result := Mapper(Obj, PropInfo);
        if Result <> nil then Exit;
      end;
  end;
  PropType := PropInfo^.PropType^;
  I := 0;
  C := nil;
  while I < PropertyClassList.Count do
  begin
    P := PropertyClassList[I];

    if ( (P^.PropertyType = PropType) {or
         ((P^.PropertyType^.Kind = PropType.Kind) and
          (P^.PropertyType^.Name = PropType.Name)
         )}
       ) or  // compatible class type
       ( (PropType^.Kind = tkClass) and
         (P^.PropertyType^.Kind = tkClass) and
         GetTypeData(PropType)^.ClassType.InheritsFrom(GetTypeData(P^.PropertyType)^.ClassType)
       ) or  // compatible interface type
       ( (PropType^.Kind = tkInterface) and
         (P^.PropertyType^.Kind = tkInterface) and
         InterfaceInheritsFrom(GetTypeData(PropType), GetTypeData(P^.PropertyType))
       ) then
      if ((P^.ComponentClass = nil) or (Obj.InheritsFrom(P^.ComponentClass))) and
         ((P^.ClassGroup = nil) or (P^.ClassGroup = ClassGroupOf(Obj))) and
         ((P^.PropertyName = '') or (CompareText(PropInfo^.Name, P^.PropertyName) = 0)) then
        if (C = nil) or   // see if P is better match than C
           ((C^.ComponentClass = nil) and (P^.ComponentClass <> nil)) or
           ((C^.PropertyName = '') and (P^.PropertyName <> ''))
           or  // P's proptype match is exact, but C's isn't
           ((C^.PropertyType <> PropType) and (P^.PropertyType = PropType))
           or  // P's proptype is more specific than C's proptype
           ( (P^.PropertyType <> C^.PropertyType) and
             ( ( // P has a more specific class type than C.
                 (P^.PropertyType^.Kind = tkClass) and
                 (C^.PropertyType^.Kind = tkClass) and
                 GetTypeData(P^.PropertyType)^.ClassType.InheritsFrom(
                   GetTypeData(C^.PropertyType)^.ClassType)
               ) or // P has a more specific interface type than C.
               ( (P^.PropertyType^.Kind = tkInterface) and
                 (C^.PropertyType^.Kind = tkInterface) and
                 InterfaceInheritsFrom(GetTypeData(P^.PropertyType), GetTypeData(C^.PropertyType))
               )
             )
           ) or // P's component class is more specific than C's component class
           ( (P^.ComponentClass <> nil) and (C^.ComponentClass <> nil) and
             (P^.ComponentClass <> C^.ComponentClass) and
             (P^.ComponentClass.InheritsFrom(C^.ComponentClass))
           ) then
          C := P;
    Inc(I);
  end;
  if C <> nil then
    Result := C^.EditorClass else
    Result := PropClassMap[PropType^.Kind];
end;

procedure GetComponentProperties(const Components: IDesignerSelections;
  Filter: TTypeKinds; const Designer: IDesigner; Proc: TGetPropProc;
  EditorFilterFunc: TPropertyEditorFilterFunc);
var
  I, J, CompCount: Integer;
  CompType: TClass;
  Candidates: TPropInfoList;
  PropLists: TList;
  EditorInstance: TBasePropertyEditor;
  Editor: IProperty;
  EdClass: TPropertyEditorClass;
  PropInfo: PPropInfo;
  AddEditor: Boolean;
  Obj: TPersistent;
begin
  if (Components = nil) or (Components.Count = 0) then Exit;
  CompCount := Components.Count;
  Obj := Components[0];
  CompType := Components[0].ClassType;
  // Create a property candidate list
  Candidates := TPropInfoList.Create(Components[0], Filter);
  try
    for I := Candidates.Count - 1 downto 0 do
    begin
      PropInfo := Candidates[I];
      EdClass := GetEditorClass(PropInfo, Obj);
      if EdClass = nil then
        Candidates.Delete(I)
      else
      begin
        EditorInstance := EdClass.Create(Designer, 1);
        Editor := EditorInstance as IProperty;
        TPropertyEditor(EditorInstance).SetPropEntry(0, Components[0], PropInfo);
        TPropertyEditor(EditorInstance).Initialize;
        with PropInfo^ do
          if (GetProc = nil) or
             (not GShowReadOnlyProps and
              ((PropType^.Kind <> tkClass) and
               (SetProc = nil))) or
             ((CompCount > 1) and
              not (paMultiSelect in Editor.GetAttributes)) or
             not Editor.ValueAvailable or
             (Assigned(EditorFilterFunc) and not EditorFilterFunc(Editor)) then
            Candidates.Delete(I);
      end;
    end;
    PropLists := TList.Create;
    try
      PropLists.Capacity := CompCount;
      // Create a property list for each component in the selection
      for I := 0 to CompCount - 1 do
        PropLists.Add(TPropInfoList.Create(Components[I], Filter));
      // Eliminate each property in Candidates that is not in all property list
      for I := 0 to CompCount - 1 do
        Candidates.Intersect(TPropInfoList(PropLists[I]));
      // Eliminate each property in the property list that are not in Candidates
      for I := 0 to CompCount - 1 do
        TPropInfoList(PropLists[I]).Intersect(Candidates);
      // PropList now has a matrix of PropInfo's, create property editors for
      // each property with given each the array of PropInfos
      for I := 0 to Candidates.Count - 1 do
      begin
        EdClass := GetEditorClass(Candidates[I], Obj);
        if EdClass = nil then Continue;
        EditorInstance := EdClass.Create(Designer, CompCount);
        Editor := EditorInstance as IProperty;
        AddEditor := True;
        for J := 0 to CompCount - 1 do
        begin
          if (Components[J].ClassType <> CompType) and
            (G