vcleditors.pas

是 delphi6的函数库

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{       Copyright (c) 1995, 2001 Borland Software Corp. }
{                                                       }
{       Windows specific property editors               }
{                                                       }
{*******************************************************}

unit VCLEditors;

interface

uses
  Messages, Types, Classes, Graphics, Menus, Controls, Forms, StdCtrls,
  DesignIntf, DesignEditors, DesignMenus, ActnList;

{ Property Editors }

type
{ ICustomPropertyDrawing
  Implementing this interface allows a property editor to take over the object
  inspector's drawing of the name and the value. If paFullWidthName is returned
  by IProperty.GetAttributes then only PropDrawName will be called. Default
  implementation of both these methods are provided in DefaultPropDrawName
  and DefaultPropDrawValue in this unit. }
  ICustomPropertyDrawing = interface
    ['{E1A50419-1288-4B26-9EFA-6608A35F0824}']
    procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
    procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
  end;

{ ICustomPropertyDrawing
  Implemention this interface allows a property editor to take over the drawing
  of the drop down list box displayed by the property editor. This is only
  meaningful to implement if the property editor returns paValueList from
  IProperty.GetAttributes. The Value parameter is the result of
  IProperty.GetValue. The implementations ListMeasureWidth and ListMeasureHeight
  can be left blank since the var parameter is filled in to reasonable defaults
  by the object inspector. A default implementation of ListDrawValue is supplied
  in the DefaultPropertyListDrawValue procedure included in this unit }
  ICustomPropertyListDrawing = interface
    ['{BE2B8CF7-DDCA-4D4B-BE26-2396B969F8E0}']
    procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;
      var AWidth: Integer);
    procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;
      var AHeight: Integer);
    procedure ListDrawValue(const Value: string; ACanvas: TCanvas;
      const ARect: TRect; ASelected: Boolean);
  end;


{ TFontNameProperty
  Editor for the TFont.FontName property.  Displays a drop-down list of all
  the fonts known by Windows.  The following global variable will make
  this property editor actually show examples of each of the fonts in the
  drop down list.  We would have enabled this by default but it takes
  too many cycles on slower machines or those with a lot of fonts.  Enable
  it at your own risk. ;-}
var
  FontNamePropertyDisplayFontNames: Boolean = False;

type
  TFontNameProperty = class(TStringProperty, ICustomPropertyListDrawing)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValues(Proc: TGetStrProc); override;

    // ICustomPropertyListDrawing
    procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;
      var AHeight: Integer);
    procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;
      var AWidth: Integer);
    procedure ListDrawValue(const Value: string; ACanvas: TCanvas;
      const ARect: TRect; ASelected: Boolean);
  end;

{ TFontCharsetProperty
  Editor for the TFont.Charset property.  Displays a drop-down list of the
  character-set by Windows.}

  TFontCharsetProperty = class(TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;
  end;

{ TImeNameProperty
  Editor for the TImeName property.  Displays a drop-down list of all
  the IME names known by Windows.}

  TImeNameProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    procedure GetValues(Proc: TGetStrProc); override;
  end;

{ TColorProperty
  Property editor for the TColor type.  Displays the color as a clXXX value
  if one exists, otherwise displays the value as hex.  Also allows the
  clXXX value to be picked from a list. }

  TColorProperty = class(TIntegerProperty, ICustomPropertyDrawing,
    ICustomPropertyListDrawing)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;

    { ICustomPropertyListDrawing }
    procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;
      var AHeight: Integer);
    procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;
      var AWidth: Integer);
    procedure ListDrawValue(const Value: string; ACanvas: TCanvas;
      const ARect: TRect; ASelected: Boolean);

    { CustomPropertyDrawing }
    procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
    procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean); 
  end;

{ TBrushStyleProperty
  Property editor for TBrush's Style.  Simply provides for custom render. }

  TBrushStyleProperty = class(TEnumProperty, ICustomPropertyDrawing,
    ICustomPropertyListDrawing)
  public
    { ICustomPropertyListDrawing }
    procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;
      var AHeight: Integer);
    procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;
      var AWidth: Integer);
    procedure ListDrawValue(const Value: string; ACanvas: TCanvas;
      const ARect: TRect; ASelected: Boolean);

    { ICustomPropertyDrawing }
    procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
    procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
  end;

{ TPenStyleProperty
  Property editor for TPen's Style.  Simply provides for custom render. }

  TPenStyleProperty = class(TEnumProperty, ICustomPropertyDrawing,
    ICustomPropertyListDrawing)
  public
    { ICustomPropertyListDrawing }
    procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;
      var AHeight: Integer);
    procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;
      var AWidth: Integer);
    procedure ListDrawValue(const Value: string; ACanvas: TCanvas;
      const ARect: TRect; ASelected: Boolean);

    { ICustomPropertyDrawing }
    procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
    procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect;
      ASelected: Boolean);
  end;

{ TCursorProperty
  Property editor for the TCursor type.  Displays the cursor as a clXXX value
  if one exists, otherwise displays the value as hex.  Also allows the
  clXXX value to be picked from a list. }

  TCursorProperty = class(TIntegerProperty, ICustomPropertyListDrawing)
  public
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;

    { ICustomPropertyListDrawing }
    procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas;
      var AHeight: Integer);
    procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas;
      var AWidth: Integer);
    procedure ListDrawValue(const Value: string; ACanvas: TCanvas;
      const ARect: TRect; ASelected: Boolean); 
  end;

{ TFontProperty
  Property editor for the Font property.  Brings up the font dialog as well as
  allowing the properties of the object to be edited. }

  TFontProperty = class(TClassProperty)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

{ TModalResultProperty }

  TModalResultProperty = class(TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;
  end;

{ TShortCutProperty
  Property editor the ShortCut property.  Allows both typing in a short
  cut value or picking a short-cut value from a list. }

  TShortCutProperty = class(TOrdinalProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
    procedure GetValues(Proc: TGetStrProc); override;
    procedure SetValue(const Value: string); override;
  end;

{ TMPFilenameProperty
  Property editor for the TMediaPlayer.  Displays an File Open Dialog
  for the name of the media file.}

  TMPFilenameProperty = class(TStringProperty)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

{ TTabOrderProperty
  Property editor for the TabOrder property.  Prevents the property from being
  displayed when more than one component is selected. }

  TTabOrderProperty = class(TIntegerProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
  end;

{ TCaptionProperty
  Property editor for the Caption and Text properties.  Updates the value of
  the property for each change instead on when the property is approved. }

  TCaptionProperty = class(TStringProperty)
  public
    function GetAttributes: TPropertyAttributes; override;
  end;

function GetDisplayValue(const Prop: IProperty): string;
procedure DefaultPropertyDrawName(Prop: TPropertyEditor; Canvas: TCanvas;
  const Rect: TRect);
procedure DefaultPropertyDrawValue(Prop: TPropertyEditor; Canvas: TCanvas;
  const Rect: TRect);
procedure DefaultPropertyListDrawValue(const Value: string; Canvas: TCanvas;
  const Rect: TRect; Selected: Boolean);

type
{ ISelectionMessage }

{ If a selection editor implements this interface the form designer will ensure
  all windows message are first sent through this interface before handling
  them when the selection editor for the corresponding class is selected.

  IsSelectionMessage - Filter for all messages processed by the designer when
    this the implementing selection editor is active. Return True if the message
    is handled by the selection editor which causes the designer to ignore
    the message (as well as preventing the control from seeing the message)
    or False, allowing the designer to process the message normally.
      Sender   the control that received the original message.
      Message  the message sent by windows to the control. }
  ISelectionMessage = interface
    ['{58274878-BB87-406A-9220-904105C9E112}']
    function IsSelectionMessage(Sender: TControl;
      var Message: TMessage): Boolean;
  end;

  ISelectionMessageList = interface
    ['{C1360368-0099-4A7C-A4A8-7650503BA0C6}']
    function Get(Index: Integer): ISelectionMessage;
    function GetCount: Integer;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: ISelectionMessage read Get; default;
  end;

function SelectionMessageListOf(const SelectionEditorList: ISelectionEditorList): ISelectionMessageList;

{ Custom Module Types }

type

{ ICustomDesignForm
  Allows a custom module to create a different form for use by the designer
  as the base form.

    CreateDesignForm - Create a descendent of TCustomForm for use by the
      designer as the instance to design }
  ICustomDesignForm = interface
    ['{787195AF-C234-49DC-881B-221B69C0137A}']
    procedure CreateDesignerForm(const Designer: IDesigner; Root: TComponent;
      out DesignForm: TCustomForm; out ComponentContainer: TWinControl);
  end;

{ Clipboard utility functions }

var
  CF_COMPONENTS: Word;

procedure CopyStreamToClipboard(S: TMemoryStream);
function GetClipboardStream: TMemoryStream;

{ EditAction utility functions }

function EditActionFor(AEditControl: TCustomEdit; Action: TEditAction): Boolean;
function GetEditStateFor(AEditControl: TCustomEdit): TEditState;

{ Registry Information }

var
  BaseRegistryKey: string = '';

{ Action Registration }

type

  TNotifyActionListChange = procedure;

var

  NotifyActionListChange: TNotifyActionListChange = nil;

procedure RegActions(const ACategory: string;
  const AClasses: array of TBasicActionClass; AResource: TComponentClass);
procedure UnRegActions(const Classes: array of TBasicActionClass);
procedure EnumActions(Proc: TEnumActionProc; Info: Pointer);
function CreateAction(AOwner: TComponent; ActionClass: TBasicActionClass): TBasicAction;

implementation

uses Consts, RTLConsts, SysUtils, Windows, Math, Dialogs, Registry, TypInfo, 
     Clipbrd, ImgList, CommCtrl;

{ Registry Information }

type

  TBasicActionRecord = record
    ActionClass: TBasicActionClass;
    GroupId: Integer;
  end;

  TActionClassArray = array of TBasicActionRecord;

  TActionClassesEntry = record
    Category: string;
    Actions: TActionClassArray;
    Resource: TComponentClass;
  end;

  TActionClassesArray = array of TActionClassesEntry;

var
  DesignersList: TList = nil;
  ActionClasses: TActionClassesArray = nil;

{ Action Registration }

type
  THackAction = class(TCustomAction);

procedure RegActions(const ACategory: string;
  const AClasses: array of TBasicActionClass; AResource: TComponentClass);
var
  CategoryIndex, Len, I, J, NewClassCount: Integer;
  NewClasses: array of TBasicActionClass;
  Skip: Boolean;
  S: string;
begin
  { Determine whether we're adding a new category, or adding to an existing one }
  CategoryIndex := -1;
  for I := Low(ActionClasses) to High(ActionClasses) do
    if CompareText(ActionClasses[I].Category, ACategory) = 0 then
    begin
      CategoryIndex := I;
      Break;
    end;

  { Adding a new category }
  if CategoryIndex = -1 then
  begin
    CategoryIndex := Length(ActionClasses);
    SetLength(ActionClasses, CategoryIndex + 1);
  end;

  with ActionClasses[CategoryIndex] do
  begin
    SetLength(NewClasses, Length(AClasses));
    { Remove duplicate classes }
    NewClassCount := 0;
    for I := Low(AClasses) to High(AClasses) do
    begin
      Skip := False;
      for J := Low(Actions) to High(Actions) do
        if AClasses[I] = Actions[I].ActionClass then
        begin
          Skip := True;
          Break;
        end;
      if not Skip then
      begin
        NewClasses[Low(NewClasses) + NewClassCount] := AClasses[I];
        Inc(NewClassCount);
      end;
    end;

    { Pack NewClasses }
    SetLength(NewClasses, NewClassCount);

    SetString(S, PChar(ACategory), Length(ACategory));
    Category := S;
    Resource := AResource;
    Len := Length(Actions);
    SetLength(Actions, Len + Length(NewClasses));
    for I := Low(NewClasses) to High(NewClasses) do
    begin
      RegisterNoIcon([NewClasses[I]]);
      Classes.RegisterClass(NewClasses[I]);
      with Actions[Len + I] do
      begin
        ActionClass := NewClasses[I];
        GroupId := CurrentGroup;
      end;
    end;
  end;
  { Notify all available designers of new TAction class }
  if (DesignersList <> nil) and Assigned(NotifyActionListChange) then
    NotifyActionListChange;
end;

procedure UnRegActions(const Classes: array of TBasicActionClass);//! far;
begin
end;

procedure UnregisterActionGroup(AGroupId: Integer);
var
  I, J: Integer;
begin
  for I := Low(ActionClasses) to High(ActionClasses) do
    for J := Low(ActionClasses[I].Actions) to High(ActionClasses[I].Actions) do
      with ActionClasses[I].Actions[J] do
        if GroupId = AGroupId then
        begin
          ActionClass := nil;
          GroupId := -1;
        end;
  if Assigned(NotifyActionListChange) then
    NotifyActionListChange;
end;

procedure EnumActions(Proc: TEnumActionProc; Info: Pointer);
var
  I, J, Count: Integer;
  ActionClass: TBasicActionClass;
begin
  if ActionClasses <> nil then
    for I := Low(ActionClasses) to High(ActionClasses) do
    begin
      Count := 0;
      for J := Low(ActionClasses[I].Actions) to High(ActionClasses[I].Actions) do
      begin
        ActionClass := ActionClasses[I].Actions[J].ActionClass;
        if ActionClass = nil then
          Continue;
        Proc(ActionClasses[I].Category, ActionClass, Info);
        Inc(Count);
      end;
      if Count = 0 then
        SetLength(ActionClasses[I].Actions, 0);
    end;
end;

function CreateAction(AOwner: TComponent; ActionClass: TBasicActionClass): TBasicAction;
var
  I, J: Integer;
  Res: TComponentClass;
  Instance: TComponent;
  Action: TBasicAction;

  function FindComponentByClass(AOwner: TComponent; const AClassName: string): TComponent;
  var
    I: Integer;
  begin
    if (AClassName <> '') and (AOwner.ComponentCount > 0) then
      for I := 0 to AOwner.ComponentCount - 1 do
      begin
        Result := AOwner.Components[I];
        if CompareText(Result.ClassName, AClassName) = 0 then Exit;
      end;
    Result := nil;
  end;

  procedure CreateMaskedBmp(ImageList: TCustomImageList; ImageIndex: Integer;
    var Image, Mask: Graphics.TBitmap);
  begin
    Image := Graphics.TBitmap.Create;
    Mask := Graphics.TBitmap.Create;
    try
      with Image do
      begin
        Height := ImageList.Height;
        Width := ImageList.Width;
      end;
      with Mask do
      begin