sfontctrls.pas

Alpha Controls.v5.46b Source

procedure TsFontListBox.SetFilterOptions(Value: TFilterOptions);
begin
  if FFilterOptions <> Value then begin
    FFilterOptions := Value;
    if not (csLoading in ComponentState) then GetFonts(Self);
  end;
end;

procedure TsFontComboBox.SetFilterOptions(Value: TFilterOptions);
begin
  if FFilterOptions <> Value then begin
    FFilterOptions := Value;
    if not (csLoading in ComponentState) then GetFonts(Self);
  end;
end;

procedure TsFontListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  tmpbitmap1, tmpbitmap2   : TBitmap;
  ARect,BRect  : TRect;
  TmpColor     : TColor;
  TmpFontClass : TFontClass;
begin
  if (Items.Objects[Index] <> nil) then begin
    TmpFontClass := TFontClass(Items.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.TextRect(Rect, Rect.Left + 2, Rect.Top + 1, TmpFontClass.FntName);
    FreeAndNil(tmpbitmap2);
    FreeAndNil(tmpbitmap1);
  end;
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 < Items.Count) and (Items.Objects[Index] <> nil) then begin
    TmpFontClass := TFontClass(Items.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 := acTextWidth(Canvas, 'Wy');
  inherited;
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(Items.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);
    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);
Exit; // v5.44
  if (Items.Count < 1) or (Items.Objects[Index] = nil) then Exit;
  if DrawFont and (Index > -1) then begin
    f := TFont.Create;
    f.Name := Items[Index];
    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; // v5.44
  if DrawFont and (Index > -1) then begin
    f := TFont.Create;
    f.Name := Items[Index];
    f.Size := Font.Size;
    Height := GetFontHeight(f.Handle);
    FreeAndNil(f);
  end;
end;

procedure TsFontListBox.WndProc(var Message: TMessage);
begin
{$IFDEF LOGGED}
  AddToLog(Message);
{$ENDIF}
  inherited;
end;

procedure TsFontListBox.Loaded;
begin
  inherited;
  GetFonts(Self);
end;

procedure TsFontComboBox.Loaded;
begin
  inherited;
  GetFonts(Self);
end;

//var
//  ThreadID : Cardinal;

initialization
  GetAllInstalledScreenFonts;
//  CreateThread(nil, 128, @GetAllInstalledScreenFonts, nil, 0, ThreadID);
  for iC := 0 to 3 do FBitmaps[iC]:= 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 iC := 0 to Length(fa) - 1 do TFontClass(fa[iC]).Free;
  SetLength(fa, 0);
  for iC := 0 to 3 do FreeAndNil(FBitmaps[iC]);

end.