tntjvcolorcombo.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

    FOnBeforeCustom(Self);
end;

procedure TTntJvColorComboBox.ChangeColor(AIndex: Integer; AColor: TColor;
  const DisplayName: WideString);
begin
  // raise Exception ?
  if (AIndex >= 0) and (AIndex < Items.Count - Ord(coCustomColors in Options)) then
  begin
    Items[AIndex] := DisplayName;
    Items.Objects[AIndex] := TObject(AColor);
  end;
end;

function TTntJvColorComboBox.ColorName(AColor: TColor): WideString;
begin
  Result := GetColorName(AColor, '');
  if Result = '' then
    DoGetDisplayName(-1, AColor, Result);
end;

function TTntJvColorComboBox.FindColor(AColor: TColor): Integer;
begin
  Result := Items.IndexOfObject(TObject(AColor));
  if (coCustomColors in Options) and (Result = Items.Count - 1) then
    Result := -1;
end;

procedure TTntJvColorComboBox.GetCustomColors(AList: TList);
var
  I, J: Integer;
begin
  if AList = nil then
    Exit;
  Items.BeginUpdate;
  try
    J := Ord((coCustomColors in Options));
    for I := Items.Count - (CustomColorCount + J) to pred(Items.Count - J) do
      AList.Add(Items.Objects[I]);
  finally
    Items.EndUpdate;
  end;
end;

procedure TTntJvColorComboBox.SetCustomColors(AList: TList);
var
  I: Integer;
  AColor: TColor;
  S: WideString;
begin
  if AList = nil then
    Exit;
  Items.BeginUpdate;
  try
    for I := 0 to AList.Count - 1 do
    begin
      AColor := TColor(AList[I]);
      if AColor <> -1 then
      begin
        S := FNewColorText;
        if DoNewColor(AColor, S) then
        begin
          InsertColor(Items.Count - 1, AColor, WideFormat(S, [FCustomColorCount]));
          Inc(FCustomColorCount);
        end;
      end;
    end;
  finally
    Items.EndUpdate;
  end;
end;

function TTntJvColorComboBox.GetCustomColorsStrings: TStrings;
var
  AList: TList;
  I: Integer;
begin
  AList := TList.Create;
  FCustomColors.BeginUpdate;
  try
    FCustomColors.Clear;
    GetCustomColors(AList);
    for I := 0 to AList.Count - 1 do
      FCustomColors.Values['Color' + Char(Ord('A') + I)] := Format('%.6x', [Integer(AList[I])]);
  finally
    AList.Free;
    FCustomColors.EndUpdate;
  end;
  Result := FCustomColors;
end;

procedure TTntJvColorComboBox.SetCustomColorsStrings(const Value: TStrings);
var
  AList: TList;
  AValue: string;
  I: Integer;
begin
  FCustomColors.Assign(Value);
  AList := TList.Create;
  FCustomColors.BeginUpdate;
  try
    for I := 0 to FCustomColors.Count - 1 do
    begin
      AValue := FCustomColors.Values['Color' + Char(Ord('A') + I)];
      if (AValue <> '') and (AValue <> 'FFFFFF') then
        {$IFDEF CLR}
        AList.Add(TObject(StrToInt('$' + AValue)));
        {$ELSE}
        AList.Add(Pointer(StrToInt('$' + AValue)));
        {$ENDIF CLR}
    end;
    SetCustomColors(AList);
  finally
    AList.Free;
    FCustomColors.EndUpdate;
  end;
end;

procedure TTntJvColorComboBox.InternalInsertColor(AIndex: Integer;
  AColor: TColor; const DisplayName: WideString);
begin
  Items.InsertObject(AIndex, DisplayName, TObject(AColor));
end;

procedure TTntJvColorComboBox.DoNameMapChange(Sender: TObject);
begin
  Invalidate;
end;

procedure TTntJvColorComboBox.Loaded;
begin
  inherited Loaded;
  HandleNeeded;
  if HandleAllocated then
    GetColors;
end;

function TTntJvColorComboBox.GetDropDownWidth: Integer;
begin
  Result := SendMessage(Handle, CB_GETDROPPEDWIDTH, 0, 0);
end;

procedure TTntJvColorComboBox.SetDropDownWidth(const Value: Integer);
begin
  SendMessage(Handle, CB_SETDROPPEDWIDTH, Value, 0);
end;

procedure TTntJvColorComboBox.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if (Parent <> nil) and HandleAllocated then
    GetColors;
end;

//=== { TTntJvFontComboBox } ====================================================

constructor TTntJvFontComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTrueTypeBmp := LoadInternalBitmap('TntJvFontComboBoxTTF');
  FFixBmp := LoadInternalBitmap('TntJvFontComboBoxFIX');
  FDeviceBmp := LoadInternalBitmap('TntJvFontComboBoxPRN');
  FHiliteColor := clHighlight;
  FHiliteText := clHighlightText;
  FDevice := fdScreen;
  FUseImages := True;
  Style := csOwnerDrawFixed;
  AutoComplete := False;
  ResetItemHeight;
end;

destructor TTntJvFontComboBox.Destroy;
begin
  FTrueTypeBmp.Free;
  FDeviceBmp.Free;
  FFixBmp.Free;
  FFontSizes.Free;
  inherited Destroy;
end;

procedure TTntJvFontComboBox.GetFonts;
var
  DC: HDC;
  MRUItems: TTntStringList;
  I: Integer;
begin
  if FUpdateCount = 0 then
  begin
    HandleNeeded;
    if not HandleAllocated then
      Exit;
    Items.BeginUpdate;
    MRUItems := TTntStringList.Create;
    try
      if FShowMRU then
        for I := 0 to MRUCount - 1 do
          MRUItems.AddObject(Items[I], Items.Objects[I]);
      Clear;
      DC := GetDC(HWND_DESKTOP);
      try
        {$IFDEF CLR}
        if FDevice in [fdScreen, fdBoth] then
          EnumFonts(DC, nil, EnumFontsProc, Self); {???}
        if FDevice in [fdPrinter, fdBoth] then
        try
          EnumFonts(Printer.Handle, nil, EnumFontsProc, Self);  {???}
        except
          // (p3) exception might be raised if no printer is installed, but ignore it here
        end;
        {$ELSE}
        if FDevice in [fdScreen, fdBoth] then
          EnumFontsW(DC, nil, @EnumFontsProc, Pointer(Self));
        if FDevice in [fdPrinter, fdBoth] then
        try
          EnumFontsW(Printer.Handle, nil, @EnumFontsProc, Pointer(Self));
        except
          // (p3) exception might be raised if no printer is installed, but ignore it here
        end;
        {$ENDIF CLR}
      finally
        ReleaseDC(HWND_DESKTOP, DC);
      end;
      if FShowMRU then
        for I := MRUCount - 1 downto 0 do
        begin
          Items.InsertObject(0, MRUItems[I], MRUItems.Objects[I]);
        end;
    finally
      MRUItems.Free;
      Items.EndUpdate;
    end;
  end;
end;

procedure TTntJvFontComboBox.SetOptions(Value: TJvFontComboOptions);
begin
  if Value <> Options then
  begin
    FOptions := Value;
    if (foPreviewFont in FOptions) then
      Exclude(FOptions, foWysiWyg);
    SetShowMRU(foMRU in FOptions);
    Reset;
  end;
end;

procedure TTntJvFontComboBox.SetUseImages(Value: Boolean);
begin
  if FUseImages <> Value then
  begin
    FUseImages := Value;
    Invalidate;
  end;
end;

procedure TTntJvFontComboBox.SetDevice(Value: TFontDialogDevice);
begin
  if Value <> FDevice then
  begin
    FDevice := Value;
    Reset;
  end;
end;

procedure TTntJvFontComboBox.CNDrawItem(var Msg: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  with Msg.DrawItemStruct{$IFNDEF CLR}^{$ENDIF} do
  begin
    State := ItemStateToOwnerDrawState(itemState);
    Canvas.Handle := hDC;
    Canvas.Font := Font;
    Canvas.Brush := Brush;
    if (Integer(itemID) >= 0) and (odSelected in State) then
    begin
      Canvas.Brush.Color := FHiliteColor;
      Canvas.Font.Color := FHiliteText;
    end;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State)
    else
      Canvas.FillRect(rcItem);
    Canvas.Handle := 0;
  end;
end;

function TTntJvFontComboBox.DoDrawPreview(const AFontName: WideString;
  var APreviewText: WideString; ATextWidth: Integer): Boolean;
begin
  Result := ATextWidth < ClientWidth;
  if Assigned(FOnDrawPreviewEvent) then
    FOnDrawPreviewEvent(Self, AFontName, APreviewText, ATextWidth, Result);
end;

procedure TTntJvFontComboBox.DrawItem(Index: Integer; R: TRect;
  State: TOwnerDrawState);
var
  ABmp: TBitmap;
  AColor: TColor;
  AWidth: Integer;
  TmpRect: TRect;
  S, AName: WideString;
begin
  with Canvas do
  begin
    AColor := Brush.Color;
    Brush.Color := Color;
    Pen.Color := Font.Color;
    FillRect(R);
    Inc(R.Top);
    //    AWidth  := 20;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      ABmp := FTrueTypeBmp
    else
    if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
      ABmp := FDeviceBmp
    else
      ABmp := FFixBmp;
    if not FUseImages then
      ABmp := nil;

    if ABmp <> nil then
    begin
      AWidth := ABmp.Width;
      BrushCopy(Bounds(R.Left + 2, (R.Top + R.Bottom - ABmp.Height) div 2,
        ABmp.Width, ABmp.Height), ABmp, Bounds(0, 0, ABmp.Width, ABmp.Height), clFuchsia);
      R.Left := R.Left + AWidth + 6;
    end
    else
      AWidth := 4;
    Brush.Color := AColor;
    AName := Canvas.Font.Name;
    if foWysiWyg in FOptions then
    begin
      if (foPreviewFont in Options) then
        Canvas.Font.Name := Self.Font.Name
      else
        Canvas.Font.Name := Items[Index];
    end;
    if not (foPreviewFont in Options) then
      R.Right := R.Left + TextWidth(Items[Index]) + 6;
    FillRect(R);
    OffsetRect(R, 2, 0);
    {$IFDEF CLR}
    DrawText(Canvas.Handle, Items[Index], -1, R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX); {???}
    {$ELSE}
    Tnt_DrawTextW(Canvas.Handle, PWideChar(Items[Index]), -1, R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
    {$ENDIF CLR}
    if (foPreviewFont in Options) then
    begin
      Inc(AWidth, TextWidth(Items[Index]) + 36);
      Canvas.Font.Name := Items[Index];
      S := 'AbCdEfGhIj';
      Inc(AWidth, TextWidth(S));
      if DoDrawPreview(Items[Index], S, AWidth) then
      begin
        TmpRect := R;
        TmpRect.Left := 0;
        TmpRect.Right := ClientWidth - (GetSystemMetrics(SM_CXVSCROLL) + 8);
        R.Right := ClientWidth;
        {$IFDEF CLR}
        DrawText(Canvas.Handle, S, -1, TmpRect, DT_SINGLELINE or DT_VCENTER or DT_RIGHT or DT_NOPREFIX); {???}
        {$ELSE}
        Tnt_DrawTextW(Canvas.Handle, PWideChar(S), -1, TmpRect, DT_SINGLELINE or DT_VCENTER or DT_RIGHT or DT_NOPREFIX);
        {$ENDIF CLR}
      end;
    end;
    Canvas.Font.Name := AName;
    OffsetRect(R, -2, 0);
    if odSelected in State then
      DrawFocusRect(R);
    if FShowMRU and not (odComboBoxEdit in State) then
    begin
      // draw MRU separator
      Dec(R.Top);
      if (Index = MRUCount - 1) then
      begin
        Canvas.Pen.Color := clGray;
        Canvas.Pen.Width := 1;
        Canvas.MoveTo(0, R.Bottom - 1);
        Canvas.LineTo(ClientWidth, R.Bottom - 1);
      end
      else
      if (Index = MRUCount) and (Index > 0) then
      begin
        Canvas.Pen.Color := clGray;
        Canvas.Pen.Width := 1;
        Canvas.MoveTo(0, R.Top + 1);
        Canvas.LineTo(ClientWidth, R.Top + 1);
      end;
    end;
  end;
end;

{procedure TTntJvFontComboBox.WMFontChange(var Msg: TMessage);
begin
  inherited;
  Reset;
end;}

procedure TTntJvFontComboBox.FontChanged;
begin
  inherited FontChanged;
  ResetItemHeight;
  RecreateWnd;
end;

procedure TTntJvFontComboBox.ResetItemHeight;
begin
  ItemHeight := Max(GetItemHeight(Font), FTrueTypeBmp.Height);
end;

function TTntJvFontComboBox.BeginUpdate: Integer;
begin
  Inc(FUpdateCount);
  Result := FUpdateCount;
end;

function TTntJvFontComboBox.EndUpdate: Integer;
begin
  Dec(FUpdateCount);
  if FUpdateCount = 0 then
    GetFonts
  else
  if FUpdateCount < 0 then
    FUpdateCount := 0;
  Result := FUpdateCount;
end;

procedure TTntJvFontComboBox.Click;
begin
  inherited Click;