fccolorcombo.pas

一套及时通讯的原码

        else result :=0;
      end
      else 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
        else result :=0;
      end;
   end;
end;

function RGBCompareGroupSys(s1,s2: string): Integer;
begin
  result := ColorCompare(s1,s2,csoByRGB,True);
end;

function IntensityCompareGroupSys(s1,s2: string): Integer;
begin
  result := ColorCompare(s1,s2,csoByIntensity,True);
end;

function RGBCompare(s1,s2: string): Integer;
begin
  result := ColorCompare(s1,s2,csoByRGB,False);
end;

function IntensityCompare(s1,s2: string): Integer;
begin
  result := ColorCompare(s1,s2,csoByIntensity,False);
end;

procedure TfcColorListFiller.ColorCallbackProc(const s: String);
const EndColors = 30; // Delphi 6 update pack 2 increases this to 30, previously 28
var AColorInt: LongInt;
    AColor: TColor;
begin
   IdentToColor(s, AColorInt);
   AColorInt := AColorInt and $00ffffff;//$0080000000;
   AColor := StringToColor(s);

   //clBlack should only show up with Standard Colors and not be associated
   //with System Colors.
   if (S='clBlack') and (ccoShowStandardColors in FOptions) then
      Flist.Add(Copy(S, 3, Length(s) - 2) + '=' + InttoHex(AColor, 6))
   else if ((S<>'clBlack') and (S<> 'clNone') and
       (((ccoShowStandardColors in FOptions) and (not (AColorInt in [COLOR_SCROLLBAR..ENDCOLORS]))
       or ((AColorInt in [COLOR_SCROLLBAR..ENDCOLORS]) and (ccoShowSystemColors in FOptions))))) then
      Flist.Add(Copy(S, 3, Length(s) - 2) + '=' + IntToHex(AColor,6));
end;

procedure TfcColorListFiller.FillColorList(var AList: TStringList;AOptions:TfcColorListBoxOptions;NoneString:String);
begin
   FList:=AList;
   if (ccoShowColorNone in AOptions) then
      FList.Add(NoneString+'='+IntToHex(clNone,6));
   FOptions := AOptions;
   GetColorValues(ColorCallbackProc);
   AList := FList;
end;

//***************** TfcColorList ********************************
procedure TfcCustomColorList.Loaded;
begin
  inherited Loaded;
  InitColorList;           //Maybe should always call?
end;

procedure TfcCustomColorList.CreateWnd;
begin
  inherited CreateWnd;
  InitColorList;           //Maybe should always call?
  if not (Owner is TfcCustomColorCombo) then exit;
  Windows.SetParent(Handle, 0);
  CallWindowProc(DefWndProc, Handle, wm_SetFocus, 0, 0);
end;

constructor TfcCustomColorList.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOptions := [ccoShowStandardColors,ccoShowColorNames];
  FCustomColors := TStringList.Create;
  FTempColors := TStringList.Create;
  FAllColors := TStringList.Create;
  FAlignment := taLeftJustify;
  FColorAlignment := taLeftJustify;
  FSortByOption := csoNone;
  FGreyScaleIncrement := 10;
  FSelectedColor := clNullColor;
  FHighlightColor := clNone;
  FHighlightTextColor := clNone;
  FColorMargin := 2;
  ColorWidth := GetEditRectHeight-1;
  //3/3/99 -PYW- Don't Default to True because of align issues.
  // IntegralHeight:= True;
  ControlStyle := ControlStyle - [csFixedHeight];
  {$IFDEF WIN32}
     ControlStyle := ControlStyle + [csReplicatable];
  {$ENDIF}
  FCustomColors.OnChange := CustomColorsChangeEvent;
  FCloseOnUp := True;
  ItemIDMap:= TList.create;
end;

destructor TfcCustomColorList.Destroy;
begin
//  DestroyHandle;
  ItemIDMap.Free;
  FCustomColors.Free;
  FAllColors.Free;
  FTempColors.Free;
  inherited Destroy;
end;

{ RSW }
procedure TfcCustomColorList.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Items.count<=0 then begin
     FCloseOnUp := True;
     exit;
  end;

  if (Button = mbLeft) and FCloseOnUp and (ItemIndex >=0) and
     (PtInRect(ClientRect, Point(X, Y))) then
  begin
     SelectedColor := StringToColor('$'+Items.Values[Items.Names[ItemIndex]]);
  end;

  inherited;
  if (Button= mbLeft) and FCloseOnUp and (Owner is TfcCustomColorCombo) and
     (FClickedInControl or PtInRect(ClientRect, Point(X, Y))) then
    (Owner as TfcCustomColorCombo).CloseUp(PtInRect(ClientRect, Point(X, Y)));

  FCloseOnUp := True;
  if not FClickedInControl then FIgnoreMouseScroll := True;
end;

procedure TfcCustomColorList.MouseMove(Shift: TShiftState; X, Y: Integer);
var itemno:integer;
begin
{  if (not FIgnoreMouseScroll) and (not FClickedInControl) and PtInRect(ClientRect, Point(x, y)) then
  begin
    if not ((FLastPoint.X=0) and (FLastPoint.Y=0)) and (Owner is TfcCustomColorCombo) then
       PostMessage(Handle, WM_LBUTTONDOWN, 0, 0); // Added to allow one-click selection and dragging.  -ksw (2/18/99)
  end;
}
  inherited;
{  if ((FLastPoint.x = x) and (FLastPoint.y = y)) or ((FLastPoint.x = -1) and (FLastPoint.y = -1)) then
  begin
    FLastPoint := Point(x, y);
    Exit;
  end;
}
{  if (FLastPoint.X=0) and (FLastPoint.Y=0) then
     FLastPoint := Point(X,Y);
  if (FLastPoint.X = X) and (FLastPoint.Y = Y) then Exit;
}
  if not (Owner is TfcCustomColorCombo) then exit;
  if FIgnoreMouseScroll then exit;
  itemno := ItemAtPos(Point(X,Y),True);
  if FPrevItem = itemno then exit;
  if (ItemIndex <> itemno) and (itemno >=0) then
     SendMessage(Handle, LB_SETCURSEL, itemno, 0);
     //ItemIndex := itemno;
  FPrevItem := itemno;
  FLastPoint := Point(X,Y);
end;

function TfcCustomColorList.HasDuplicateNames(var dup:String): Boolean;
var i,j:integer;
  function CompareColorStrings(s1,s2: string): Integer;
  begin
     if (AnsiCompareStr(s1,NoneString) = 0) and
        (AnsiCompareStr(s2,NoneString) <> 0) then
        result := -1
     else if (AnsiCompareStr(s2,NoneString) = 0) and
        (AnsiCompareStr(s1,NoneString) <> 0) then
        result := 1
     else
        result := AnsiComparestr(s1,s2);
  end;
begin
  result := False;
  for i:= 0 to FAllColors.count-1 do begin
     for j:=i+1 to FAllColors.Count-1 do begin
         if CompareColorStrings(FAllColors.Names[i],FAllColors.Names[j])=0 then begin
            dup := FAllColors.Names[j];
            result := True;
            exit;
         end;
     end;
  end;
end;

{
procedure TfcColorList.ListChange(Sender: TObject);
var dup:String;
begin
  if HasDuplicateNames(dup) then
     raise EInvalidOperation.Create('Duplicate Color Names not allowed');
end;
}

procedure TfcCustomColorList.SetOptions(Value: TfcColorListBoxOptions);
begin
   if (Value <> FOptions) then begin
     FOptions := Value;
     if not (csLoading in ComponentState) then InitColorList;
   end;
end;

procedure TfcCustomColorList.UpdateItems;
var i:integer;
    accept:boolean;
begin
   Items.Clear;                  //Update Items with list of color names.
   ItemIDMap.Clear;
   for i := 0 to FAllColors.Count - 1 do
   begin
       if Assigned(FOnFilterColor) then begin
          accept := True;
          FOnFilterColor(self, fcGetColorFromList(FAllColors,i), fcGetNamesFromStringList(FAllColors,i), accept);
          if not accept then continue;
       end;
       ItemIDMap.Add(Pointer(i));
       Items.Add(FAllColors.strings[i]);
   end;
end;

function TfcCustomColorList.ColorFromIndex(Index: Integer):TColor;
begin
  result := fcGetColorFromList(Items,Index);
end;

procedure TfcCustomColorList.SortList;
var i:integer;
    curcolor:TColor;
//    ColorValue:String;
begin
   FListBoxUpdated:= True;
   curcolor:= FSelectedColor;
{   if ItemIndex <> -1 then
     ColorValue := Items.Names[ItemIndex]
   else ColorValue := '';}

            //If there are entries and Sorted is True then Sort the list.
   //2/26/99 - Don't Check Sorted Anymore.
   if {(Sorted = True) and }(FAllColors.Count > 0) then begin
     case SortBy of
        csoByRGB:
           if not (ccoGroupSystemColors in Options) then
              fcQuickSort(FAllColors, 0, FAllColors.Count - 1, RGBCompare, fcGetValuesFromStringList)
           else
              fcQuickSort(FAllColors, 0, FAllColors.Count - 1, RGBCompareGroupSys, fcGetValuesFromStringList);
        csoByIntensity:
           if not (ccoGroupSystemColors in Options) then
              fcQuickSort(FAllColors, 0, FAllColors.Count - 1, IntensityCompare, fcGetValuesFromStringList)
           else
              fcQuickSort(FAllColors, 0, FAllColors.Count - 1, IntensityCompareGroupSys, fcGetValuesFromStringList);
        csoByName:
           if (ccoGroupSystemColors in Options) then
             //2/26/99 - Already Sorted if ByName.
{              fcQuickSort(FAllColors, 0, FAllColors.Count - 1, ColorNamesCompare, fcGetItemsFromStringList)
           else}
              fcQuickSort(FAllColors, 0, FAllColors.Count - 1, ColorNamesCompareGroupSys, fcGetItemsFromStringList);
     end;
   end;

   UpdateItems;
   {    3/4//99 - Call UpdateItems method instead.
   Items.Clear;
   ItemIDMap.Clear;
   for i := 0 to FAllColors.Count - 1 do
   begin
       if Assigned(FOnFilterColor) then begin
          accept := True;
          FOnFilterColor(self, fcGetColorFromList(FAllColors,i), fcGetNamesFromStringList(FAllColors,i), accept);
          if not accept then continue;
       end;
       ItemIDMap.Add(Pointer(i));
       Items.Add(FAllColors.strings[i]);
   end;}

   i := fcValueInList(IntToHex(curcolor,6),FAllColors);
   if i<> -1 then i := Items.indexofname(allcolors.Names[i]);
   if i >= 0 then ItemIndex := i;   //Reset cursor if listbox has a current color
end;

procedure TfcCustomColorList.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do begin
    Style := Style or LBS_OWNERDRAWFIXED;
    WindowClass.Style := CS_DBLCLKS;
  end;

  if not (Owner is TfcCustomColorCombo) then exit;

  with Params do
  begin
    Style := Style or WS_BORDER;
    ExStyle := WS_EX_TOOLWINDOW;
    WindowClass.Style := CS_SAVEBITS;
    ControlStyle := ControlStyle + [csNoDesignVisible];
  end;
end;

procedure TfcCustomColorList.DoDrawItem(ACanvas:TCanvas; Index,CWidth,CHeight:Integer; Rect: TRect;
   State: TOwnerDrawState; Text:String; AColor:TColor);
var CurColor: TColor;
    ColorRect, TextRect: TRect;
    OrigPenColor,OrigColor,OrigFontColor:TColor;
    OrigBKMode:Longint;
    NoneFlag,ShowText:Boolean;
    NoneStr:String;

  function HighlightCol: TColor;
  begin
    if (odSelected in State) then result := GetHighlightColor
    else result := OrigColor;
  end;
  function HighlightTextCol: TColor;
  begin
    if (odSelected in State) then result := GetHighlightTextColor
    else result := OrigFontColor;
  end;

begin
  OrigColor := ACanvas.Brush.Color;
  OrigFontColor := ACanvas.Font.Color;
  OrigPenColor := ACanvas.Pen.Color;
  OrigBkMode := GetBKMode(ACanvas.Handle);

  if (Index = -1) and (Text = '') then
  begin
    if (odSelected in State) then begin
       SetBkMode(ACanvas.Handle,Opaque);
       ACanvas.Brush.Color := GetHighlightColor;
       ACanvas.FillRect(Rect);
       SetBkColor(ACanvas.Handle,ColorToRGB(GetHighlightColor));
       SetTextColor(ACanvas.Handle,ColorToRGB(GetHighlightTextColor));
       ACanvas.DrawFocusRect(Rect);
    end
    else begin
       SetBkMode(ACanvas.Handle,Opaque);
       ACanvas.Brush.Color := HighlightCol;
       ACanvas.FillRect(Rect);
       ACanvas.Brush.Color := OrigFontColor;
       ACanvas.DrawFocusRect(Rect);
    end;
    ACanvas.Brush.Color := OrigColor;
    ACanvas.Font.Color := OrigFontColor;
    ACanvas.Pen.Color := OrigPenColor;
    Exit;
  end;

  if AColor = clNullColor then CurColor := clNone
  else CurColor := AColor;

  if (CurColor = clNone) and (AColor <> clNullColor) then begin
     CurColor := OrigColor; //Make None Color same as background?????}
     NoneFlag := True;
  end
  else NoneFlag := False;

  ShowText := False;
  if ccoShowColorNames in Options then ShowText := True;

  if ShowText then
  begin

    if Alignment = taLeftJustify then begin
       if (ColorAlignment = taLeftJustify) then
          ColorRect := Classes.Rect(Rect.Left + ColorMargin, Rect.Top + ((Rect.Bottom-Rect.Top-CHeight) div 2),
                                Rect.Left + ColorMargin + CWidth, Rect.Bottom - ((Rect.Bottom-Rect.Top-CHeight) div 2))