suifontcombobox.pas

SUIPack是一款为Delphi和C++Builder开发的所见即所得的界面增强VCL组件

const
  WRITABLE_FONTTYPE = 256;

function IsValidFont(Box: TsuiFontComboBox; LogFont: TLogFont; FontType: Integer): Boolean;
begin
  Result := True;
  if (foAnsiOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
  if (foTrueTypeOnly in Box.Options) then
    Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
  if (foFixedPitchOnly in Box.Options) then
    Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
  if (foOEMFontsOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
  if (foNoOEMFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
  if (foNoSymbolFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
  if (foScalableOnly in Box.Options) then
    Result := Result and (FontType and RASTER_FONTTYPE = 0);
end;

function EnumFontsProc(var EnumLogFont: TEnumLogFont;
  var TextMetric: TNewTextMetric; FontType: Integer; Data: LPARAM): Integer;
  export; stdcall;
var
  FaceName: string;
begin
  FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  with TsuiFontComboBox(Data) do
    if (Items.IndexOf(FaceName) < 0) and
      IsValidFont(TsuiFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then begin
      if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
        FontType := FontType or WRITABLE_FONTTYPE;
      Items.AddObject(FaceName, TObject(FontType));
    end;
  Result := 1;
end;

constructor TsuiFontComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ItemHeight := 15;
  FTrueTypeBMP := CreateBitmap('FONTCOMBO_TRUETYPE_FNT');
  FDeviceBMP := CreateBitmap('FONTCOMBO_DEVICE_FNT');
  FDevice := fdScreen;
  Sorted := True;

  inherited ItemHeight := MinItemHeight;
end;

destructor TsuiFontComboBox.Destroy;
begin
  FTrueTypeBMP.Free;
  FDeviceBMP.Free;
  inherited Destroy;
end;

procedure TsuiFontComboBox.CreateWnd;
var
  OldFont: TFontName;
begin
  OldFont := FontName;
  inherited CreateWnd;
  FUpdate := True;
  try
    PopulateList;
    inherited Text := '';
    SetFontName(OldFont);
  finally
    FUpdate := False;
  end;
  if AnsiCompareText(FontName, OldFont) <> 0 then
    DoChange;
end;

procedure TsuiFontComboBox.PopulateList;
var
  DC: HDC;
begin
  if not HandleAllocated then Exit;
  Items.BeginUpdate;
  try
    Clear;
    DC := GetDC(0);
    try
      if (FDevice = fdScreen) or (FDevice = fdBoth) then
        EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
      if (FDevice = fdPrinter) or (FDevice = fdBoth) then
        try
          EnumFontFamilies(Printer.Handle, nil, @EnumFontsProc, Longint(Self));
        except
          { skip any errors }
        end;
    finally
      ReleaseDC(0, DC);
    end;
  finally
    Items.EndUpdate;
  end;
end;

procedure TsuiFontComboBox.SetFontName(const NewFontName: TFontName);
var
  Item: Integer;
begin
  if FontName <> NewFontName then begin
    if not (csLoading in ComponentState) then begin
      HandleNeeded;
      { change selected item }
      for Item := 0 to Items.Count - 1 do
        if AnsiCompareText(Items[Item], NewFontName) = 0 then begin
          ItemIndex := Item;
          DoChange;
          Exit;
        end;
      if Style = csDropDownList then
        ItemIndex := -1
      else
        inherited Text := NewFontName;
    end
    else
      inherited Text := NewFontName;
    DoChange;
  end;
end;

function TsuiFontComboBox.GetFontName: TFontName;
begin
  Result := inherited Text;
end;

procedure TsuiFontComboBox.SetOptions(Value: TFontListOptions);
begin
  if Value <> Options then begin
    FOptions := Value;
    Reset;
  end;
end;

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

procedure TsuiFontComboBox.SetUseFonts(Value: Boolean);
begin
  if Value <> FUseFonts then begin
    FUseFonts := Value;
    Invalidate;
  end;
end;

procedure TsuiFontComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  BmpWidth: Integer;
  Text: array[0..255] of Char;
begin
  with Canvas do begin
    FillRect(Rect);
    BmpWidth  := 20;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      Bitmap := FTrueTypeBMP
    else
      if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
        Bitmap := FDeviceBMP
      else
        Bitmap := nil;
    if Bitmap <> nil then begin
      BmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
        div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
        Bitmap.Height), Bitmap.TransparentColor);
    end;
    { uses DrawText instead of TextOut in order to get clipping against
      the combo box button }
    {TextOut(Rect.Left + bmpWidth + 6, Rect.Top, Items[Index])}
    StrPCopy(Text, Items[Index]);
    Rect.Left := Rect.Left + BmpWidth + 6;
    if FUseFonts and (Integer(Items.Objects[Index]) and WRITABLE_FONTTYPE <> 0) then
      Font.Name := Items[Index];
    DrawText(Handle, Text, StrLen(Text), Rect,
      DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX));
  end;
end;

procedure TsuiFontComboBox.WMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

function TsuiFontComboBox.MinItemHeight: Integer;
begin
  Result := inherited MinItemHeight;
  if Result < FTrueTypeBMP.Height - 1 then
    Result := FTrueTypeBMP.Height - 1;
end;

procedure TsuiFontComboBox.Change;
var
  I: Integer;
begin
  inherited Change;
  if Style <> csDropDownList then begin
    I := Items.IndexOf(inherited Text);
    if (I >= 0) and (I <> ItemIndex) then begin
      ItemIndex := I;
      DoChange;
    end;
  end;
end;

procedure TsuiFontComboBox.Click;
begin
  inherited Click;
  DoChange;
end;

procedure TsuiFontComboBox.DoChange;
begin
  if not (csReading in ComponentState) then
    if not FUpdate and Assigned(FOnChange) then
      FOnChange(Self);
end;

procedure TsuiFontComboBox.Reset;
var
  SaveName: TFontName;
begin
  if HandleAllocated then begin
    FUpdate := True;
    try
      SaveName := FontName;
      PopulateList;
      FontName := SaveName;
    finally
      FUpdate := False;
      if FontName <> SaveName then
        DoChange;
    end;
  end;
end;

function EnumFontSizes( var EnumLogFont : TEnumLogFont; PTextMetric : PNewTextMetric; FontType : Integer; Data : LPARAM ) : Integer; export; stdcall;
var
  s : String;
  i : Integer;
  v : Integer;
  v2 : Integer;
begin
  if (FontType and TRUETYPE_FONTTYPE)<>0 then begin
    TsuiFontSizeComboBox(Data).Items.Add('8');
    TsuiFontSizeComboBox(Data).Items.Add('9');
    TsuiFontSizeComboBox(Data).Items.Add('10');
    TsuiFontSizeComboBox(Data).Items.Add('11');
    TsuiFontSizeComboBox(Data).Items.Add('12');
    TsuiFontSizeComboBox(Data).Items.Add('14');
    TsuiFontSizeComboBox(Data).Items.Add('16');
    TsuiFontSizeComboBox(Data).Items.Add('18');
    TsuiFontSizeComboBox(Data).Items.Add('20');
    TsuiFontSizeComboBox(Data).Items.Add('22');
    TsuiFontSizeComboBox(Data).Items.Add('24');
    TsuiFontSizeComboBox(Data).Items.Add('26');
    TsuiFontSizeComboBox(Data).Items.Add('28');
    TsuiFontSizeComboBox(Data).Items.Add('36');
    TsuiFontSizeComboBox(Data).Items.Add('48');
    TsuiFontSizeComboBox(Data).Items.Add('72');
    Result := 0;
  end
  else begin
    v := Round( ( EnumLogFont.elfLogFont.lfHeight - PTextMetric.tmInternalLeading ) * 72 / TsuiFontSizeComboBox( Data ).PixelsPerInch );
    s := IntToStr( v );
    Result := 1;
    for i := 0 to Pred( TsuiFontSizeComboBox( Data ).Items.Count ) do begin
      v2 := StrToInt( TsuiFontSizeComboBox( Data ).Items[ i ] );
      if v2 = v then
        exit;
      if v2 > v then begin
        TsuiFontSizeComboBox( Data ).Items.Insert( i, s );
        exit;
      end;
    end;
    TsuiFontSizeComboBox( Data ).Items.Add( s );
  end;
end;

procedure TsuiFontSizeComboBox.Build;
var
  DC : HDC;
  OC : TNotifyEvent;
begin
  DC := GetDC( 0 );
  Items.BeginUpdate;
  try
    Items.Clear;
    if FontName <> '' then begin
      PixelsPerInch := GetDeviceCaps( DC, LOGPIXELSY );
      EnumFontFamilies( DC, PChar( FontName ), @EnumFontSizes, Longint( Self ) );
      OC := OnClick;
      OnClick := nil;
      ItemIndex := Items.IndexOf( Text );
      OnClick := OC;
      if Assigned( OnClick ) then
        OnClick( Self );
    end;
  finally
    Items.EndUpdate;
    ReleaseDC( 0, DC );
  end;
end;

procedure TsuiFontSizeComboBox.SetFontName( const Value : TFontName );
begin
  FFontName := Value;
  Build;
end;

constructor TsuiFontSizeComboBox.Create(AOwner: TComponent);
begin
    inherited;

    self.Style := csDropDownList;
end;

function TsuiFontSizeComboBox.GetFontSize: Integer;
begin
    try
        Result := StrToInt(Items[ItemIndex]);
    except
        Result := 0;
    end;
end;

procedure TsuiFontSizeComboBox.SetFontSize(const Value: Integer);
begin
    ItemIndex := Items.IndexOf(IntToStr(Value));
end;

end.