cxfontnamecombobox.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,058 行 · 第 1/5 页

    property MaxMRUFonts;
    property OEMConvert;
    property PopupAlignment;
    property PostPopupValueOnTab;
    property ReadOnly;
    property ShowFontTypeIcon;
    property UseOwnFont;
    property ValidateOnEnter;
    property OnAddedMRUFont;
    property OnChange;
    property OnCloseUp;
    property OnDeletedMRUFont;
    property OnDrawItem;
    property OnEditValueChanged;
    property OnInitPopup;
    property OnLoadFontComplete;
    property OnMeasureItem;
    property OnMovedMRUFont;
    property OnNewLookupDisplayText;
    property OnPopup;
    property OnValidate;
  end;

  { TcxCustomFontNameComboBoxInnerEdit }

  TcxCustomFontNameComboBoxInnerEdit = class(TcxCustomComboBoxInnerEdit);

  { TcxCustomFontNameComboBox }

  TcxCustomFontNameComboBox = class(TcxCustomComboBox)
  private
    FDontCheckModifiedWhenUpdatingMRUList: Boolean;
    FFontNameQueue: string;
    FNeedsUpdateMRUList: Boolean;
    function GetFontName: string;
    procedure SetFontName(Value: string);
    function GetLookupData: TcxFontNameComboBoxLookupData;
    function GetProperties: TcxCustomFontNameComboBoxProperties;
    function GetActiveProperties: TcxCustomFontNameComboBoxProperties;
    procedure SetProperties(Value: TcxCustomFontNameComboBoxProperties);
    procedure InternalLoadFontCompleteHandler(Sender: TObject);
    procedure UpdateMRUList;
  protected
    procedure AfterPosting; override;
    procedure InternalSetEditValue(const Value: TcxEditValue;
      AValidateEditValue: Boolean); override;
    function GetInnerEditClass: TControlClass; override;
    function GetPopupWindowClientPreferredSize: TSize; override;
    procedure Initialize; override;
    procedure InitializePopupWindow; override;
    procedure CloseUp(AReason: TcxEditCloseUpReason); override;
    procedure SetItemIndex(Value: Integer); override;
    property LookupData: TcxFontNameComboBoxLookupData read GetLookupData;
  public
  {$IFDEF CBUILDER10}
    constructor Create(AOwner: TComponent); override;
  {$ENDIF}
    function Deactivate: Boolean; override;
    class function GetPropertiesClass: TcxCustomEditPropertiesClass; override;
    function AddMRUFontName(const AFontName: TFontName): TcxMRUFontNameAction;
    function DelMRUFontName(const AFontName: TFontName): TcxMRUFontNameAction;
    property ActiveProperties: TcxCustomFontNameComboBoxProperties
      read GetActiveProperties;
    property FontName: string read GetFontName write SetFontName;
    property Properties: TcxCustomFontNameComboBoxProperties read GetProperties
      write SetProperties;
  end;

  { TcxFontNameComboBox }

  TcxFontNameComboBox = class(TcxCustomFontNameComboBox)
  private
    function GetActiveProperties: TcxFontNameComboBoxProperties;
    function GetProperties: TcxFontNameComboBoxProperties;
    procedure SetProperties(Value: TcxFontNameComboBoxProperties);
  public
    class function GetPropertiesClass: TcxCustomEditPropertiesClass; override;
    property ActiveProperties: TcxFontNameComboBoxProperties
      read GetActiveProperties;
  published
    property Anchors;
    property AutoSize;
    property BeepOnEnter;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property ImeMode;
    property ImeName;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property Properties: TcxFontNameComboBoxProperties read GetProperties
      write SetProperties;
    property ShowHint;
    property Style;
    property StyleDisabled;
    property StyleFocused;
    property StyleHot;
    property TabOrder;
    property TabStop;
    property Text;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEditing;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

  { TcxFilterFontNameComboBoxHelper }

  TcxFilterFontNameComboBoxHelper = class(TcxFilterComboBoxHelper)
  public
    class function GetFilterEditClass: TcxCustomEditClass; override;
    class function GetSupportedFilterOperators(
      AProperties: TcxCustomEditProperties;
      AValueTypeClass: TcxValueTypeClass;
      AExtendedSet: Boolean = False): TcxFilterControlOperators; override;
  end;

var
  FTrueTypeFontBitmap, FNonTrueTypeFontBitmap : TBitmap;

procedure GetFontSizes(const AFontName: string; AFontSizes: TStrings);
function GetFontTypes(const AFontName: string): TcxFontTypes;
function RealFontTypeToCxTypes(const AFontType: Integer): TcxFontTypes;

implementation

uses 
{$IFDEF DELPHI6}  
  Types,
{$ENDIF}
  cxListBox;

{$R cxFontNameComboBox.res}

type
  TCanvasAccess = class(TCanvas);

const
  DropDownListTextOffset = 2;
  NUM_SIZES = 16;
  caiFontSizes: array[0 .. NUM_SIZES - 1] of Integer =
    (8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72);
  cxFontPreviewPanelDefaultHeight = 38;
  IconBorderWidth = 4;
  IconTextOffset = 2;
  ItemSymbolFontExampleOffset = 4;

var
  FFontList: TStringList;
  FFontSizes: TStrings;
  vbFtt : Boolean;

function RealFontTypeToCxTypes(const AFontType: Integer): TcxFontTypes;
begin
  Result := [];
  if (AFontType and TRUETYPE_FONTTYPE) <> 0 then
    Result := Result + [cxftTTF];
  if (AFontType and RASTER_FONTTYPE) <> 0 then
    Result := Result + [cxftRaster];
  if (AFontType and DEVICE_FONTTYPE) <> 0 then
    Result := Result + [cxftDevice];
  if (AFontType and FIXEDPITCH_FONTTYPE) <> 0 then
    Result := Result + [cxftFixed];
  if (AFontType and SYMBOL_FONTTYPE) <> 0 then
    Result := Result + [cxftSymbol];
end;

function IsValidFontCondition(AFontTypes: TcxFontTypes;
  const ALogFont: TLogFont; AFontType: Integer): Boolean;
begin
  Result :=
    ((cxftTTF in AFontTypes) and (AFontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE)) or
    ((cxftDevice in AFontTypes) and (AFontType and DEVICE_FONTTYPE = DEVICE_FONTTYPE)) or
    ((cxftRaster in AFontTypes) and (AFontType and RASTER_FONTTYPE = RASTER_FONTTYPE)) or
    ((cxftFixed in AFontTypes) and (ALogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH)) or
    ((cxftSymbol in AFontTypes) and (ALogFont.lfCharSet = SYMBOL_CHARSET));
end;

function EnumFontsProc(var ALogFont: TLogFont; var ATextMetric: TTextMetric;
  AFontType: DWORD; AData: LPARAM): Integer; stdcall;
begin
  if ALogFont.lfCharSet = SYMBOL_CHARSET then
    AFontType := AFontType or SYMBOL_FONTTYPE;
  if ALogFont.lfPitchAndFamily = FIXED_PITCH then
    AFontType := AFontType or FIXEDPITCH_FONTTYPE;
  FFontList.AddObject(ALogFont.lfFaceName, TObject(Integer(AFontType)));
  Result := 0;
end;

function EnumFontsProc2(AFontLoader: TcxFontLoader; const ALogFont: TLogFont;
  AFontType: DWORD): Integer;
var
  AFaceName: string;
begin
  AFaceName := ALogFont.lfFaceName;
  if (AFontLoader.FontList.IndexOf(AFaceName) = -1) and
    IsValidFontCondition(AFontLoader.FFontTypes, ALogFont, AFontType) then
  begin
    if ALogFont.lfCharSet = SYMBOL_CHARSET then
      AFontType := AFontType or SYMBOL_FONTTYPE;
    if ALogFont.lfPitchAndFamily = FIXED_PITCH then
      AFontType := AFontType or FIXEDPITCH_FONTTYPE;
    AFontLoader.FontList.AddObject(AFaceName, TObject(Integer(AFontType)));
  end;
  if AFontLoader.Terminated then
    Result := 0
  else
    Result := 1;
end;

function EnumFontsProc1(var ALogFont: TLogFont;
  var ATextMetric: TTextMetric; AFontType: DWORD;
  AData: LPARAM): Integer; stdcall;
begin
  Result := EnumFontsProc2(TcxFontLoader(AData), ALogFont, AFontType);
end;

procedure InitLogFont(var ALogFont: TLogFont; const AFontName: string);
begin
  FillChar(ALogFont, SizeOf(ALogFont), 0);
  StrPCopy(ALogFont.lfFaceName, AFontName);
  ALogFont.lfCharset := DEFAULT_CHARSET;
end;

function GetFontTypes(const AFontName: string): TcxFontTypes;

  procedure EnumFonts;
  var
    ADC: HDC;
    ALogFont: TLogFont;
  begin
    ADC := GetDC(0);
    try
      InitLogFont(ALogFont, AFontName);
      EnumFontFamiliesEx(ADC, ALogFont, @EnumFontsProc, 0, 0);
    finally
      ReleaseDC(0, ADC);
    end;
  end;

begin
  FFontList := TStringList.Create;
  try
    Result := [];
    EnumFonts;
    if FFontList.Count > 0 then
      Result := RealFontTypeToCxTypes(Integer(FFontList.Objects[0]));
  finally
    FFontList.Free;
  end;
end;

function SetFontSizes(var ALogFont: TLogFont; var ATextMetric: TTextMetric;
  AFontType: DWORD; AData: LPARAM): Integer; stdcall;
var
  S: string;
begin
  S := IntToStr(((ATextMetric.tmHeight - ATextMetric.tmInternalLeading) * 72 +
    ATextMetric.tmDigitizedAspectX div 2) div ATextMetric.tmDigitizedAspectY);
  if FFontSizes.IndexOf(S) = -1 then
    FFontSizes.Add(S);
  Result := 1;
end;

function SetFTypeFlag(var ALogFont: TLogFont; var ATextMetric: TTextMetric;
  AFontType: DWORD; AData: LPARAM): Integer; stdcall;
begin
  vbFtt := (ATextMetric.tmPitchAndFamily and TMPF_TRUETYPE) = TMPF_TRUETYPE;
  Result := 0;
end;

procedure GetFontSizes(const AFontName: string; AFontSizes: TStrings);

  function IsTrueTypeFont(ADC: HDC; var ALogFont: TLogFont): Boolean;
  begin
    EnumFontFamiliesEx(ADC, ALogFont, @SetFTypeFlag, 0, 0);
    Result := vbFtt;
  end;

var
  ADC: HDC;
  ALogFont: TLogFont;
  I: Integer;
begin
  ADC := GetDC(0);
  try
    InitLogFont(ALogFont, AFontName);
    FFontSizes := AFontSizes;
    FFontSizes.Clear;
    if IsTrueTypeFont(ADC, ALogFont) then
      for I := 0 to NUM_SIZES - 1 do
        AFontSizes.Add(Format('%d',[caiFontSizes[I]]))
    else
      EnumFontFamiliesEx(ADC, ALogFont, @SetFontSizes, 0, 0);
  finally
    ReleaseDC(0, ADC);
  end;
end;

{ TcxFontLoader }

constructor TcxFontLoader.Create(const AFontTypes: TcxFontTypes);
begin
  FFontTypes := AFontTypes;
  FontList := TStringList.Create;
  inherited Create(True);
  FreeOnTerminate := True;
end;

destructor TcxFontLoader.Destroy;
begin
  Synchronize(DoCompleteEvent);
  if Assigned(FontList) then
    FreeAndNil(FontList);
  Synchronize(DoDestroyEvent);
  inherited Destroy;
end;

procedure TcxFontLoader.DoCompleteEvent;
begin
  if Assigned(OnCompleteThread) then OnCompleteThread(Self);
end;

procedure TcxFontLoader.DoDestroyEvent;
begin
  if Assigned(OnDestroyThread) then OnDestroyThread(Self);
end;

procedure TcxFontLoader.Execute;

  procedure EnumFonts;
  var
    ADC: HDC;
    ALogFont: TLogFont;
  begin
    ADC := GetDC(0);
    try
      InitLogFont(ALogFont, '');
      EnumFontFamiliesEx(ADC, ALogFont, @EnumFontsProc1, LPARAM(Self), 0);
    finally
      ReleaseDC(0, ADC);
    end;
  end;

begin
  try
    FontList.BeginUpdate;
    FontList.Clear;
    EnumFonts;
    TStringList(FontList).Sort;
  finally
    FontList.EndUpdate;
  end;
end;

{ TcxFontPreview }

constructor TcxFontPreview.Create(AOwner: TPersistent);
begin
  inherited Create;
  FOwner := AOwner;
  FUpdateCount := 0;
  FModified := False;
  FFontStyle := [];
  FVisible := True;
  FPreviewType := cxfpFontName;
  FPreviewText := '';
  FAlignment := taCenter;
  FShowEndEllipsis := True;
  FColor := clWindow;
  FWordWrap := False;
  FShowButtons := True;
end;

destructor TcxFontPreview.Destroy;
begin
  FIsDestroying := True;
  inherited Destroy;
end;

procedure TcxFontPreview.Assign(Source: TPersistent);
begin
  if Source is TcxFontPreview then
  begin
    BeginUpdate;
    try
      with Source as TcxFontPreview do
      begin
        Self.Visible := Visible;
        Self.FontStyle := FontStyle;
        Self.PreviewType := PreviewType;