fccolorcombo.pas

一套及时通讯的原码

    Function IsDroppedDown: boolean; override;
    procedure DrawInGridCell(ACanvas:TCanvas;Rect:TRect;State:TGridDrawState); override;
    procedure DropDown; override;
    Function ExecuteColorDialog: boolean; virtual;
    function GetColorFromRGBString(RGBString:String; var AColor:TColor):boolean;
    Procedure GetColorRectInfo(Rect:TRect;var AWidth:Integer;var AHeight:Integer);
    procedure RefreshList; virtual;

    property ListBox: TfcColorList read FListBox;
    property DroppedDown: boolean read isDroppedDown;
    property SelectedColor: TColor read FSelectedColor write SetSelectedColor;

    property UnboundAlignment: TLeftRight read GetEffectiveAlignment write SetAlignment default taLeftJustify;
//    property AlignmentVertical: TfcAlignVertical read FAlignmentVertical write SetAlignmentVertical default fcavTop;
    property AutoDropDown : boolean read FAutoDropDown write FAutoDropDown default False;
    property ButtonStyle default cbsDownArrow;
    property ColorAlignment: TLeftRight read FColorAlignment write SetColorAlignment default taLeftJustify;
    //3/4/99 - Unused property.
//    property ColorDataType: TfcColorComboDataType read FDataType write FDataType default ccdColorName;
    property ColorDialog: TColorDialog read FColorDialog write FColorDialog;
    property ColorDialogOptions: TfcColorDialogOptions read FColorDialogOptions write FColorDialogOptions default [cdoPreventFullOpen];
    property ColorListOptions: TfcColorListOptions read FColorListOptions write FColorListOptions;
    property CustomColors: TStringList read FCustomColors write SetCustomColors;
    property SelectedColorString: string read GetSelectedColorString write SetSelectedColorString;
//    property DropDownCount : integer read FDropDownCount write FDropDownCount default 8;
    property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
    property ItemIndex: integer read FItemIndex write SetItemIndex;
    property ShowMatchText: Boolean read FShowMatchText write FShowMatchText default True;
    property OnAddNewColor: TfcAddNewColorEvent read FOnAddNewColor write FOnAddNewColor;
    property OnFilterColor: TfcOnFilterColorEvent read FOnFilterColor write FOnFilterColor;
//    property OnCloseUp;//: TfcCloseColorComboEvent read FOnCloseUp write FOnCloseUp;
//    property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
    property OnInitColorDialog: TfcColorDialogEvent read FOnInitColorDialog write FOnInitColorDialog;
    property OnCloseColorDialog: TfcCloseColorDialogEvent read FOnCloseColorDialog write FOnCloseColorDialog;
//    property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
  end;

  TfcColorCombo = class(TfcCustomColorCombo)
  published
    property Controller;
    property DisableThemes;

    {$ifdef fcDelphi5Up}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property ParentBiDiMode;
    {$endif}

    property DataField;
    property DataSource;
    property InfoPower;

    property UnboundAlignment;
    property AlignmentVertical;
    property AllowClearKey;
    property AutoDropDown;
    property AutoSelect;
    property AutoSize;
    property ShowButton;
    property BorderStyle;
    property ButtonStyle;
    property ButtonEffects;
    property ButtonGlyph;
    property ButtonWidth;
    property CharCase;
    property Color;
    property ColorAlignment;
    //3/4/99 - Unused property.
    //property ColorDataType;
    property ColorDialog;
    property ColorDialogOptions;
    property ColorListOptions;
    property CustomColors;
    property Ctl3D;
    property DragMode;
    property DragCursor;
    property DropDownCount;
    property DropDownWidth;
    property Enabled;
    property Frame;
    property Font;
    {$ifdef ver100}
    property ImeMode;
    property ImeName;
    {$endif}
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property ShowMatchText;
    property SelectedColor;
    property Style default csDropDownList;
    property TabOrder;
    property TabStop;
    property Visible;

    property OnAddNewColor;
    property OnFilterColor;
    property OnChange;
    property OnClick;
    {$ifdef fcDelphi5Up}
    property OnContextPopup;
    {$endif}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnCloseUp;
    property OnInitColorDialog;
    property OnCloseColorDialog;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
end;

//procedure Register;

implementation

//       {$R FirstClass.dcr}
{May wish to move the following functions to some common file}
{function ColorStringToHex(AColor: string): TColor;
var HexString: string;
begin
  result := clNone;
  HexString := AColor;
  if HexString = '' then Exit;
  HexString := '$00' + HexString;
  result := StringToColor(HexString);
end;}

procedure TfcCustomColorList.CustomColorsChangeEvent(Sender: TObject);
begin
   InitColorList;
end;

procedure TfcCustomColorList.WMNCHitTest(var Message: TWMNCHitTest);
begin
  DefaultHandler(Message);
end;

procedure TfcCustomColorList.Click;
begin
  OldSelectedColor := FSelectedColor;
  if ItemIndex>=0 then
     FSelectedColor := StringToColor('$'+Items.Values[Items.Names[ItemIndex]]);
  //2/26/99 - Moved to ensure SelectedColor is updated before click event.
  inherited;
end;

procedure FillColorList(var AList: TStringList;AOptions:TfcColorListBoxOptions;NoneString:String);
var fill:TfcColorListFiller;
begin
   fill:= TfcColorListFiller.create;
   fill.FillColorList(AList,AOptions,NoneString);
   fill.free;
end;

{function ColorNamesCompare(s1,s2: string): Integer;
var placement1, placement2: Integer;
    Value1, Value2:String;
begin
  placement1 := 1;
  placement2 := 1;

  value1:= Copy(s1,pos('=',s1)+1,8);
  value2 := Copy(s2,pos('=',s2)+1,8);
  if StringToColor('$'+value1) = clNone then
     placement1 := 0;
  if StringToColor('$'+value2) = clNone then
     placement2 := 0;

  if placement1 < placement2 then result := -1
  else if placement1 > placement2 then result := 1
  else result := AnsiComparestr(Copy(s1,1,pos('=',s1)),Copy(s2,1,pos('=',s2)));
end;
}

function ColorNamesCompareGroupSys(s1,s2: string): Integer;
var placement1, placement2: Integer;
    Value1, Value2: string;
begin
   if (Length(Copy(s1,pos('=',s1)+1,length(s1)))=8) and
      (AnsiComparestr(Copy(s1,pos('=',s1)+1,2),'80')=0) then
     placement1 := 2  //Group System Colors
   else placement1 := 1;

   if (Length(Copy(s2,pos('=',s2)+1,length(s2)))=8) and
      (AnsiComparestr(Copy(s2,pos('=',s2)+1,2),'80')=0) then
     placement2 := 2  //Group System Colors
   else placement2 := 1;

   value1:= Copy(s1,pos('=',s1)+1,8);
   value2 := Copy(s2,pos('=',s2)+1,8);
   if StringToColor('$'+value1) = clNone then
     placement1 := 0;
   if StringToColor('$'+value2) = clNone then
      placement2 := 0;

   if placement1 < placement2 then result := -1
   else if placement1 > placement2 then result := 1
   else result := AnsiComparestr(Copy(s1,1,pos('=',s1)),Copy(s2,1,pos('=',s2)));
end;

function ColorCompare(s1,s2: string;sortby:TfcSortByOption;seperatesyscolors:boolean): Integer;
var red1,green1,blue1,reserved1:Byte;
    red2,green2,blue2,reserved2:Byte;
    placement1, placement2: integer;

  function Highest(int1, int2, int3: integer): integer;
  begin
    if (int1=int2) and (int1=int3) then result :=0
    else if (int1 >= int2) and (int1 >= int3) then result := 1
    else if (int2 >= int1) and (int2 >= int3) then result := 2
    else result := 3;
  end;

  function Lowest(int1, int2, int3: integer): integer;
  begin
    if (int1 = int2) and (int1 = int3) then result := 0
    else if (int1 <= int2) and (int1 <= int3) then result := 1
    else if (int2 <= int1) and (int2 <= int3) then result := 2
    else result :=3;
  end;

  function GetAverage(r1,g1,b1:integer):integer;
  begin
    result := (r1+g1+b1) div 3;
  end;

  function GetPlacement(r,g,b: integer): integer;
  var tolerance:integer;
      val:double;
  begin
    tolerance:=16;     //?Maybe make this configurable???? Public property?
    result := 15;
    if Highest(r,g,b)=0 then begin
       exit;
    end
    else if Highest(r,g,b)=1 then begin
       if (R>G) and (G>B) then begin
          val := (R-G);
          val := (val/R)*100.0;
          if (val < tolerance) then result := 2     //GreenishYellow color
          else begin
             val := (G/R)*100.0;
             if (val < tolerance) then
                result := 14
             else result :=1;
          end;
       end
       else if (R=G) and (G>B) then result :=2
       else if (R=B) and (B>G) then result :=12
       else if (R>B) and (B>G) then begin
          val := (R-B);
          val := (val/R)*100.0;
          if (val < tolerance) then result := 12     //GreenishYellow color
          else begin
             val := (B/R)*100.0;
             if (val < tolerance) then result := 14
             else result :=13;
          end;
       end
       else if (R>G) and (G=B) then result :=14
    end
    else if Highest(r,g,b)=2 then begin
       if (G>B) and (B>R) then begin
          val := (G-B);
          val := (val/G)*100.0;
          if (val < tolerance) then
             result := 7                 //Treat as G=B Placement
          else begin
             val := (B/G)*100.0;
             if (val < tolerance) then result := 4  //Treat as basically Green
             else result :=6;           //Treat as before G>B
          end;
       end
       else if (G>R) and (R>B) then begin
          val := (G-R);
          val := (val/G)*100.0;
          if (val < tolerance) then
             result := 3      //Treat as G=R
          else begin
             val := (R/G)*100.0;
             if (val < tolerance) then result := 4
             else result :=3;
          end;
       end
       else if (G>R) and (R=B) then result :=5
       else if (G=B) and (B>R) then result :=7
    end
    else if Highest(r,g,b)=3 then begin
       if (B>G) and (G>R) then begin
          val := (B-G);
          val := (val/B)*100.0;
          if (val < tolerance) then result := 7
          else begin
            val := (G/B)*100.0;
            if (val < tolerance) then result := 9
            else result :=8
          end;
       end
       else if (B>G) and (G=R) then result :=10
       else if (B>R) and (R>G) then
       begin
          val := (B-R);
          val := (val/B)*100.0;
          if (val < tolerance) then result := 12
          else begin
            val := (R/B)*100.0;
            if val < tolerance then result :=9
            else result :=11;
          end;
       end
    end
  end;
begin
   if s1=s2 then begin
     result := 0;
     exit;
   end;

   //Get RGB values for each color....
   fcColorToByteValues(ColorToRGB(StringToColor('$'+s1)),reserved1,blue1,green1,red1);
   fcColorToByteValues(ColorToRGB(StringToColor('$'+s2)),reserved2,blue2,green2,red2);

   //Sort either by csoByRGB or csoByIntensity
   if (SortBy = csoByRGB) then begin
     placement1 := getplacement(red1,green1,blue1);
     placement2 := getplacement(red2,green2,blue2);
   end
   else begin
   {For Intensity Seperate Colors and Greys. Put GreyScale at the Bottom}
      if (red1=green1) and (red1=blue1) then
         placement1:= 2
      else placement1:=1;

      if (red2=green2) and (red2=blue2) then
         placement2:= 2
      else placement2:=1;
   end;

   if seperatesyscolors then begin
      if (Copy(s1,1,2)='80') then
         placement1 := placement1+16;
      if (Copy(s2,1,2)='80') then
         placement2 := placement2+16;
   end;

   if s1='1FFFFFFF' then
      placement1 := 0;

   if s2='1FFFFFFF' then
      placement2 := 0;

   if placement1 < placement2 then result := -1
   else if placement1 > placement2 then result := 1
   else begin
      if (not (SortBy = csoByRGB)) or ((placement1 mod 2) = 1) then begin
        if GetAverage(red1,green1,blue1) < GetAverage(red2,green2,blue2) then
           result :=-1
        else if GetAverage(red1,green1,blue1) > GetAverage(red2,green2,blue2) then
           result :=1