tntjvcolorcombo.pas

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

  Change;
  if FShowMRU and FWasMouse and not DroppedDown then
  begin
    ItemIndex := AddToMRU;
    FWasMouse := False;
  end;
end;

procedure TTntJvFontComboBox.Reset;
var
  S: WideString;
begin
  HandleNeeded;
  if HandleAllocated then
  begin
    FreeAndNil(FFontSizes);
    S := FontName;
    GetFonts;
    if S <> '' then
      FontName := S
    else
      FontName := Font.Name;
  end;
end;

function TTntJvFontComboBox.GetFontName: WideString;
begin
  Result := inherited Text;
end;

procedure TTntJvFontComboBox.SetFontName(const Value: WideString);
begin
  HandleNeeded;
  if HandleAllocated and (Value <> '') then
  begin
    if Items.Count = 0 then
      GetFonts;
    ItemIndex := Items.IndexOf(Value);
    if ItemIndex = -1 then // try to find the font substitute name
      ItemIndex := Items.IndexOf(FontSubstitute(Value));
    if (ItemIndex = -1) and (foDisableVerify in Options) then // add if allowed to
      ItemIndex := Items.AddObject(Value, TObject(TRUETYPE_FONTTYPE));
    FreeAndNil(FFontSizes);
  end;
end;

procedure TTntJvFontComboBox.Loaded;
begin
  inherited Loaded;
  Reset;
end;

function TTntJvFontComboBox.GetSorted: Boolean;
begin
  Result := inherited Sorted;
end;

procedure TTntJvFontComboBox.SetSorted(const Value: Boolean);
var
  S: WideString;
begin
  if Value <> inherited Sorted then
  begin
    S := FontName;
    if not FShowMRU then
      inherited Sorted := Value
    else
      inherited Sorted := False;
    FontName := S;
  end;
end;

function TTntJvFontComboBox.FontSubstitute(const AFontName: WideString): WideString;
var
  {$IFDEF CLR}
  sb: StringBuilder;
  Size: Integer;
  {$ELSE}
  Size: DWORD;
  {$ENDIF CLR}
  AKey: HKey;
begin
  Result := AFontName;
  if AFontName = '' then
    Exit;
  if RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar('SOFTWARE'Microsoft'Windows NT'CurrentVersion'FontSubstitutes'),
    0, KEY_QUERY_VALUE, AKey) = ERROR_SUCCESS then
  try
    {$IFDEF CLR}
    if (RegQueryValueEx(AKey, AFontName, nil, nil, nil, Size) = ERROR_SUCCESS) and {???}
       (Size > 0) then
    begin
      sb := StringBuilder.Create(Size);
      if RegQueryValueEx(AKey, AFontName, nil, nil, sb, Size) = ERROR_SUCCESS then {???}
        Result := sb.ToString()
      else
        Result := AFontName;
    end;
    {$ELSE}
    if (RegQueryValueExW(AKey, PWideChar(AFontName),
      nil, nil, nil, @Size) = ERROR_SUCCESS) and (Size > 0) then
    begin
      SetLength(Result, Size);
      if RegQueryValueExW(AKey, PWideChar(AFontName), nil, nil, PByte(@Result[1]), @Size) = ERROR_SUCCESS then
        Result := WideString(Result)
      else
        Result := AFontName;
    end;
    {$ENDIF CLR}
  finally
    RegCloseKey(AKey);
  end
  else
    Result := AFontName;
end;

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

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

procedure TTntJvFontComboBox.SetShowMRU(const Value: Boolean);
begin
  if FShowMRU <> Value then
  begin
    if FShowMRU then
      ClearMRU;
    FShowMRU := Value;
    if FShowMRU and Sorted then
      Sorted := False;
  end;
end;

var
  FPixelsPerInch: Integer = 96;

{$IFDEF CLR}
function GetFontSizesEnum(var lpelf: TEnumLogFont; var lpntm: TNewTextMetric;
  FontType: DWORD; lParam: TObject): Integer;
type
  Pointer = TObject;
{$ELSE}
function GetFontSizesEnum(var lpelf: TEnumLogFont; var lpntm: TNewTextMetric;
  FontType: Integer; lParam: Integer): Integer; stdcall;
{$ENDIF CLR}
var
  aSize: Integer;
begin
  aSize := MulDiv(lpelf.elfLogFont.lfHeight, 72, FPixelsPerInch);
  if TList(lParam).IndexOf(Pointer(aSize)) < 0 then
    TList(lParam).Add(Pointer(aSize));
  Result := 1;
end;

{$IFDEF CLR}
function SizeSort(Item1, Item2: TObject): Integer;
begin
  Result := Integer(Item1) - Integer(Item2);
end;
{$ELSE}
function SizeSort(Item1, Item2: Pointer): Integer;
begin
  Result := Integer(Item1) - Integer(Item2);
end;
{$ENDIF CLR}

function TTntJvFontComboBox.IsTrueType: Boolean;
begin
  if ItemIndex >= 0 then
    Result := (Integer(Items.Objects[ItemIndex]) and TRUETYPE_FONTTYPE) <> 0
  else
    Result := False;
end;

procedure TTntJvFontComboBox.FontSizeList(SizeList: TList);
const
  cTTSizes: array [0..15] of Integer =
    (8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72);
var
  DC: HDC;
  I:Integer;
begin
  if SizeList = nil then
    Exit;
  SizeList.Clear;
  if IsTrueType then
  begin
    // fill in constant sizes for true type fonts
    SizeList.Clear;
    for I := Low(cTTSizes) to High(cTTSizes) do
      {$IFDEF CLR}
      SizeList.Add(TObject(cTTSizes[I]));
      {$ELSE}
      SizeList.Add(Pointer(cTTSizes[I]));
      {$ENDIF CLR}
  end
  else
  begin
    DC := GetDC(HWND_DESKTOP);
    try
      FPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
      {$IFDEF CLR}
      EnumFontFamilies2(DC, FontName, GetFontSizesEnum, SizeList);
      {$ELSE}
      EnumFontFamiliesW(DC, PWideChar(FontName), @GetFontSizesEnum, Integer(SizeList));
      {$ENDIF CLR}
      SizeList.Sort(SizeSort);
    finally
      ReleaseDC(HWND_DESKTOP, DC);
    end;
  end;
end;

function TTntJvFontComboBox.AddToMRU: Integer;
var
  I: Integer;
begin
  Result := ItemIndex;
  if csDesigning in ComponentState then
    Exit;
  if (MaxMRUCount = 0) or (MaxMRUCount > MRUCount) then
  begin
    I := Items.IndexOf(Text);
    if (I > MRUCount - 1) and (I >= 0) then
    begin
      Items.InsertObject(0, Items[I], Items.Objects[I]);
      Inc(FMRUCount);
    end
    else
    if I < 0 then
    begin
      Items.InsertObject(0, Text, TObject(TRUETYPE_FONTTYPE));
      Inc(FMRUCount);
    end;
    Result := 0;
  end
  else
  if (MRUCount > 0) and (ItemIndex > 0) then
  begin
    Items[0] := Items[ItemIndex];
    Items.Objects[0] := Items.Objects[ItemIndex];
    Result := 0;
  end;
end;

procedure TTntJvFontComboBox.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FWasMouse := False;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TTntJvFontComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FWasMouse := True;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TTntJvFontComboBox.CloseUp;
begin
  inherited CloseUp;
  if FShowMRU then
  begin
    AddToMRU;
    ItemIndex := Items.IndexOf(Text);
    FWasMouse := False;
  end;
end;

procedure TTntJvFontComboBox.ClearMRU;
begin
  while FMRUCount > 0 do
  begin
    Items.Delete(0);
    Dec(FMRUCount);
  end;
end;

procedure TTntJvFontComboBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
  // (rom) only accept without Shift, Alt or Ctrl down
  if (Shift * KeyboardShiftStates = []) and
    (Key = VK_RETURN) and FShowMRU then
    ItemIndex := AddToMRU;
  inherited KeyDown(Key, Shift);
end;

procedure TTntJvFontComboBox.SetMaxMRUCount(const Value: Integer);
var
  S: WideString;
begin
  if FMaxMRUCount <> Value then
  begin
    FMaxMRUCount := Value;
    if (FMaxMRUCount > 0) and (FMRUCount > 0) then
    begin
      S := Text;
      while FMRUCount > FMaxMRUCount do
      begin
        Items.Delete(0);
        Dec(FMRUCount);
      end;
      ItemIndex := Items.IndexOf(S);
      if ItemIndex < 0 then
        ItemIndex := 0;
    end;
  end;
end;

procedure TTntJvFontComboBox.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if (Parent <> nil) then
    FontName := Font.Name;
end;

{$IFDEF CLR}
function EnumFontSizeProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: DWORD; Param: TObject): Integer;
var
  tmp: Integer;
  FontCombo: TJvFontComboBox;
begin
  FontCombo := TJvFontComboBox(Param);
{$ELSE}
function EnumFontSizeProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; FontCombo: TTntJvFontComboBox): Integer; stdcall;
var
  tmp: Integer;
begin
{$ENDIF CLR}
  if FontType and TRUETYPE_FONTTYPE <> TRUETYPE_FONTTYPE then // TTF's don't have size info
  begin
    tmp := Round(((TextMetric.tmHeight - TextMetric.tmInternalLeading) * 72) / GetDeviceCaps(FontCombo.FEnumeratorDC, LOGPIXELSY));
    FontCombo.FFontSizes.AddObject(IntToStr(tmp), TObject(tmp));
    Result := 1;
  end
  else
    Result := 0;
end;

function IntegerSort(List: TStringList; Index1, Index2: Integer): Integer;
begin
  Result := StrToIntDef(List[Index1], 0) - StrToIntDef(List[Index2], 0);
end;

function TTntJvFontComboBox.GetFontSizes: TStrings;
begin
  if FFontSizes = nil then
    FFontSizes := TStringlist.Create;
  FFontSizes.Clear;
  TStringlist(FFontSizes).Sorted := true;

  {$IFDEF CLR}
  FEnumeratorDC := GetDC(HWND_DESKTOP);
  try
    if FDevice in [fdScreen, fdBoth] then
      EnumFonts(FEnumeratorDC, FontName, EnumFontSizeProc, Self);
  finally
    ReleaseDC(HWND_DESKTOP, FEnumeratorDC);
  end;
  if FDevice in [fdPrinter, fdBoth] then
  try
    FEnumeratorDC := Printer.Handle;
    EnumFonts(FEnumeratorDC, FontName, EnumFontSizeProc, Self);
  except
    // ignore exceptions (printer may not be installed)
  end;
  {$ELSE}
  FEnumeratorDC := GetDC(HWND_DESKTOP);
  try
    if FDevice in [fdScreen, fdBoth] then
      EnumFontsW(FEnumeratorDC, PWideChar(FontName), @EnumFontSizeProc, Pointer(Self));
  finally
    ReleaseDC(HWND_DESKTOP, FEnumeratorDC);
  end;
  if FDevice in [fdPrinter, fdBoth] then
  try
    FEnumeratorDC := Printer.Handle;
    EnumFontsW(FEnumeratorDC, PWideChar(FontName), @EnumFontSizeProc, Pointer(Self));
  except
    // ignore exceptions (printer may not be installed)
  end;
  {$ENDIF CLR}

  TStringlist(FFontSizes).Sorted := false;
  if FFontSizes.Count > 1 then
    TStringlist(FFontSizes).CustomSort(IntegerSort)
  else // true type font or font with only one size, so fake it:
  begin
    FFontSizes.Clear;
    FFontSizes.AddObject('8', TObject(8));
    FFontSizes.AddObject('9', TObject(9));
    FFontSizes.AddObject('10', TObject(10));
    FFontSizes.AddObject('11', TObject(11));
    FFontSizes.AddObject('12', TObject(12));
    FFontSizes.AddObject('14', TObject(14));
    FFontSizes.AddObject('16', TObject(16));
    FFontSizes.AddObject('18', TObject(18));
    FFontSizes.AddObject('20', TObject(20));
    FFontSizes.AddObject('22', TObject(22));
    FFontSizes.AddObject('24', TObject(24));
    FFontSizes.AddObject('26', TObject(26));
    FFontSizes.AddObject('28', TObject(28));
    FFontSizes.AddObject('36', TObject(36));
    FFontSizes.AddObject('48', TObject(48));
    FFontSizes.AddObject('72', TObject(72));
  end;
  Result := FFontSizes;
end;

{$IFDEF UNITVERSIONING}


initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.