sfontctrls.pas

Alpha Controls 界面控件包

  GetAllInstalledScreenFonts(Self);
end;

Destructor TsFontListBox.Destroy;
begin
  FreeAndNil(FontStringList);
  inherited Destroy;
end;

Destructor TsFontComboBox.Destroy;
begin
  FreeAndNil(FontStringList);
  inherited Destroy;
end;

procedure TsFontListBox.CreateWnd;
begin
  inherited CreateWnd;
  Items.BeginUpdate;
  if FontStringList <> nil then Items.Assign(FontStringList);
  Items.EndUpdate;
end;

procedure TsFontComboBox.CreateWnd;
begin
  inherited CreateWnd;
  if FontStringList <> nil then Items.Assign(FontStringList);
end;

procedure TsFontListBox.Rebuild;
begin
  if csLoading in ComponentState then Exit;
  FontStringList.Clear;
  GetAllInstalledScreenFonts(Self);
  Items.BeginUpdate;
  Items.Assign(FontStringList);
  Items.EndUpdate;
end;

procedure TsFontComboBox.Rebuild;
begin
  if csLoading in ComponentState then Exit;
  FontStringList.Clear;
  GetAllInstalledScreenFonts(Self);
  Items.BeginUpdate;
  Items.Assign(FontStringList);
  Items.EndUpdate;
end;

procedure TsFontListBox.SetFilterOptions(Value: TFilterOptions);
begin
  if FFilterOptions <> Value then begin
    FFilterOptions := Value;
    Rebuild;
  end;
end;

procedure TsFontComboBox.SetFilterOptions(Value: TFilterOptions);
begin
  if FFilterOptions <> Value then begin
    FFilterOptions := Value;
    Rebuild;
  end;
end;

procedure TsFontListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  tmpbitmap1, tmpbitmap2   : TBitmap;
  ARect,BRect  : TRect;
  TmpColor     : TColor;
  TmpFontClass : TFontClass;
begin
  TmpFontClass := TFontClass(FontStringList.Objects[Index]);
  tmpbitmap1 := TBitmap.Create;
  tmpbitmap1.Assign(FBitmaps[ord(TmpFontClass.FntType)]);
  if odSelected in State then TmpColor := clHighLight else TmpColor := Color;

  arect.left   := 0;
  arect.top    := 0;
  arect.bottom := tmpbitmap1.Height;
  arect.right  := tmpbitmap1.Width;

  Canvas.FillRect(Rect);
  tmpbitmap2 := TBitmap.Create;
  tmpbitmap2.Height      := tmpbitmap1.Height;
  tmpbitmap2.Width       := tmpbitmap1.Width;
  tmpbitmap2.canvas.Brush.Color := TmpColor;
  tmpbitmap2.canvas.BrushCopy(ARect, tmpbitmap1, ARect, clWhite); // white is transparent in bitmap

  brect.left   := rect.left;
  brect.top    := rect.top;
  brect.bottom := rect.bottom;
  brect.right  := rect.bottom - rect.top + rect.left;

  Canvas.CopyRect(bRect, TmpBitmap2.Canvas, ARect);
  Rect.Left := Rect.Left + brect.right;
  if DrawFont then Canvas.Font.Name := TmpFontClass.FntName;
//  canvas.Font.Size := HeightOf(Rect);
//  Canvas.TextOut(Rect.Left + 2, Rect.Top + 1, TmpFontClass.FntName);
  Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 1, TmpFontClass.FntName);
  FreeAndNil(tmpbitmap2);
  FreeAndNil(tmpbitmap1);
end;

procedure TsFontComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  tmpbitmap1, tmpbitmap2   : TBitmap;
  ARect,BRect  : TRect;
  TmpColor     : TColor;
  TmpFontClass : TFontClass;
begin
  if (Index > 0) and (Index < FontStringList.Count) then begin
    TmpFontClass := TFontClass(FontStringList.Objects[Index]);
    tmpbitmap1 := TBitmap.Create;
    tmpbitmap1.Assign(FBitmaps[ord(TmpFontClass.FntType)]);
    if odSelected in State then TmpColor := ColorToRGB(clHighLight) else TmpColor := ColorToRGB(Color);

    arect.left   := 0;
    arect.top    := 0;
    arect.bottom := tmpbitmap1.Height;
    arect.right  := tmpbitmap1.Width;

    Canvas.Brush.Color := TmpColor;
    Canvas.FillRect(Rect);
    tmpbitmap2 := TBitmap.Create;
    tmpbitmap2.Height      := tmpbitmap1.Height;
    tmpbitmap2.Width       := tmpbitmap1.Width;
    tmpbitmap2.canvas.Brush.Color := TmpColor;
    tmpbitmap2.canvas.BrushCopy(ARect, tmpbitmap1, ARect, clWhite); // white is transparent in bitmap

    brect.left   := rect.left;
    brect.top    := rect.top;
    brect.bottom := rect.bottom;
    brect.right  := rect.bottom - rect.top + rect.left;

    Canvas.CopyRect(bRect, TmpBitmap2.Canvas, ARect);
    Rect.Left := Rect.Left + brect.right;
    if DrawFont then Canvas.Font.Name := TmpFontClass.FntName;
    if odSelected in State then Canvas.Font.Color := ColorToRGB(clHighlightText) else Canvas.Font.Color := Font.Color;
    Canvas.TextRect(Rect, Rect.Left + 1, Rect.Top + 1, TmpFontClass.FntName);
    FreeAndNil(tmpbitmap2);
    FreeAndNil(tmpbitmap1);
  end
  else begin
    if odSelected in State then TmpColor := clHighLight else TmpColor := Color;
    FillDC(Canvas.Handle, Rect, ColorToRGB(TmpColor));
  end;
end;

procedure TsFontListBox.CMFontChanged(var Message: TMessage);
begin
  SkinData.FCacheBMP.Canvas.Font.Assign(Font);
  ItemHeight := GetStringSize(Font.Handle, 'Wg').cy;// Canvas.TextHeight(' ');
  inherited;
end;

procedure TsFontComboBox.CMFontChanged(var Message: TMessage);
begin
//  Style := csDropDownList;
  inherited;
//  ItemHeight := ItemHeight;
//  Style := csOwnerDrawVariable;
end;

procedure TsFontListBox.SetDrawFont(const Value: boolean);
begin
  if FDrawFont <> Value then begin
    FDrawFont := Value;
    if not (csLoading in ComponentState) then Invalidate;
  end;
end;

procedure TsFontComboBox.SetDrawFont(const Value: boolean);
begin
  if FDrawFont <> Value then begin
    FDrawFont := Value;
    if not (csLoading in ComponentState) then Invalidate;
  end;
end;

procedure TsFontComboBox.PaintText;
var
  tmpbitmap1,
  tmpbitmap2   : TBitmap;
  ARect,BRect  : TRect;
  TmpColor     : TColor;
  TmpFontClass : TFontClass;
  R : TRect;
begin
inherited; Exit; // !!!
  TmpColor := 0;
  if Focused then inherited else begin
    R := Rect(3, 3, Width - 3 - GetSystemMetrics(SM_CXVSCROLL), Height - 3);
    if itemIndex < 0 then Exit;
    TmpFontClass := TFontClass(FontStringList.Objects[ItemIndex]);
    tmpbitmap1 := TBitmap.Create;
    tmpbitmap1.Assign(FBitmaps[ord(TmpFontClass.FntType)]);
    with arect do begin
      left   := 0;
      top    := 0;
      bottom := tmpbitmap1.Height;
      right  := tmpbitmap1.Width;
    end;
    tmpbitmap2 := TBitmap.Create;
    with tmpbitmap2, canvas do begin
      Height      := tmpbitmap1.Height;
      Width       := tmpbitmap1.Width;
      Brush.Color := TmpColor;
      BrushCopy(ARect, tmpbitmap1, ARect, clLime);//tmpbitmap1.Canvas.Pixels[1, 1]); // white is transparent in bitmap
    end;
    with brect do begin
      left   := r.left;
      top    := r.top;
      bottom := r.bottom;
      right  := r.bottom - r.top + r.left;
    end;
    with SkinData.FCacheBmp.Canvas do begin
      CopyRect(bRect, TmpBitmap2.Canvas, ARect);
      R.Left := R.Left + brect.right + 2;
      SkinData.FCacheBMP.Canvas.Font.Assign(Self.Font);
      if DrawFont then SkinData.FCacheBMP.Canvas.Font.Name := TmpFontClass.FntName;
      WriteTextEx(SkinData.FCacheBMP.Canvas, PChar(Text), True, R, DT_NOPREFIX or DT_TOP or DT_SINGLELINE or GetStringFlags(Self, Alignment),
                  SkinData, ControlIsActive(SkinData));
  //    TextRect(R, R.Left + 2, R.Top + 1, TmpFontClass.FntName);
    end;
    FreeAndNil(tmpbitmap2);
    FreeAndNil(tmpbitmap1);
  end;
end;

procedure TsFontListBox.MeasureItem(Index: Integer; var Height: Integer);
var
  f : TFont;
begin
  inherited MeasureItem(Index, Height);
  if DrawFont and (Index > -1) then begin
    f := TFont.Create;
    f.Name := TFontClass(FontStringList.Objects[Index]).FntName;
    f.Size := Font.Size;
    Height := GetFontHeight(f.Handle);
    FreeAndNil(f);
  end;
end;

procedure TsFontComboBox.MeasureItem(Index: Integer; var Height: Integer);
var
  f : TFont;
begin
  inherited MeasureItem(Index, Height);
Exit; // !!!
  if DrawFont and (Index > -1) then begin
    f := TFont.Create;
    f.Name := TFontClass(FontStringList.Objects[Index]).FntName;
    f.Size := Font.Size;
    Height := GetFontHeight(f.Handle);
    FreeAndNil(f);
  end;
end;

initialization
  for i := 0 to 3 do FBitmaps[i]:= TBitmap.Create;
  FBitmaps[0].Handle := LoadBitmap(hinstance, 'PS');
  FBitmaps[1].Handle := LoadBitmap(hinstance, 'TTF');
  FBitmaps[2].Handle := LoadBitmap(hinstance, 'RASTER');
  FBitmaps[3].Handle := LoadBitmap(hinstance, 'UNKNOWN');

finalization
{$WARNINGS OFF}
  for i := 0 to 3 do FreeAndNil(FBitmaps[i]);

end.