Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 26.04.2010, 16:17   #1
XerSon
Форумчанин
 
Аватар для XerSon
 
Регистрация: 21.01.2008
Сообщений: 211
По умолчанию Вывод текста на TBitmap при включенном ClearType

Всем Привет,

При выводе текста в TBitmap
Процедуры:
Код:
procedure CopyTransparentBitmap(_B_in, _B_out: Tbitmap; _x, _y: integer;
  trColor: Tcolor; _transparent: integer);
var
  x, y, x_cor, y_cor, x_corS, y_corS: Integer;
  RowOut, RowIn: PRGBArray;
  _r, _b, _g: integer;
  rc1, bc1, gc1: byte;
begin
  if (_x) > _B_out.Width - 1 then
    exit;
  if (_x + _B_out.Width) < 0 then
    exit;
  if (_y) > _B_out.Height - 1 then
    exit;
  if (_y + _B_out.Height) < 0 then
    exit;
  _B_in.PixelFormat := pf24bit; //убрать, если изначально этот формат
  _B_out.PixelFormat := pf24bit; //убрать, если изначально этот формат
  if _x < 0 then
    x_corS := abs(_x)
  else
    x_corS := 0;
  if _y < 0 then
    y_corS := abs(_y)
  else
    y_corS := 0;
  if (_x + _B_in.Width) > _B_out.Width then
    x_cor := _x + _B_in.Width - _B_out.Width
  else
    x_cor := 0;
  if (_y + _B_in.Height) > _B_out.Height then
    y_cor := _y + _B_in.Height - _B_out.Height
  else
    y_cor := 0;
  rc1 := GetRValue(trColor);
  gc1 := GetGValue(trColor);
  bc1 := GetBValue(trColor);
  for y := y_corS to _B_in.Height - 1 - y_cor do
  begin
    RowOut := _B_out.ScanLine[y + _y];
    RowIn := _B_in.ScanLine[y];
    for x := x_corS to _B_in.Width - 1 - x_cor do
      if not ((RowIn[x].rgbtRed = rc1) and (RowIn[x].rgbtGreen = gc1) and
        (RowIn[x].rgbtBlue = bc1)) then
      begin
        _r := trunc(RowOut[x + _x].rgbtRed + (((RowIn[x].rgbtRed - RowOut[x +
          _x].rgbtRed) / 100) * _transparent));
        if _r > 255 then
          _r := 255;
        if _r < 0 then
          _r := 0;
        _g := trunc(RowOut[x + _x].rgbtGreen + (((RowIn[x].rgbtGreen - RowOut[x
          + _x].rgbtGreen) / 100) * _transparent));
        if _g > 255 then
          _g := 255;
        if _g < 0 then
          _g := 0;
        _b := trunc(RowOut[x + _x].rgbtBlue + (((RowIn[x].rgbtBlue - RowOut[x +
          _x].rgbtBlue) / 100) * _transparent));
        if _b > 255 then
          _b := 255;
        if _b < 0 then
          _b := 0;
        RowOut[x + _x].rgbtRed := _r;
        RowOut[x + _x].rgbtGreen := _g;
        RowOut[x + _x].rgbtBlue := _b;
      end;
  end
end;

procedure DrawTransparentText(_B_out: Tbitmap; _x, _y: integer; font: Tfont;
  _transparent: integer; _text: string);
var
  _F_out: Tbitmap;
begin
  _F_out := Tbitmap.Create;
  try
    _F_out.PixelFormat := pf24bit;
    _F_out.Canvas.Font := font;
    _F_out.Width := _F_out.Canvas.TextWidth(_text);
    _F_out.Height := _F_out.Canvas.TextHeight(_text);
    if (_F_out.Width + _x) > _B_out.Width then
      _F_out.Width := _B_out.Width - _x;
    if (_F_out.Height + _y) > _B_out.Height then
      _F_out.Height := _B_out.Height - _y;
    _F_out.Canvas.Brush.Color := font.Color + 1;
    _F_out.Canvas.TextOut(0, 0, _text);
    CopyTransparentBitmap(_F_out, _B_out, _x, _y, font.Color + 1, _transparent);
  finally
    _F_out.Free;
  end;
end;
Реализация:
Код:
DrawTransparentText(Image1.Picture.Bitmap, 10, 10, Label1.Font, 100, Edit1.Text);
В итоге на Bitmap'e получаю контуры букв разорванными (еле читаемые)!
При отключении в Windows 7 - ClearType, все отображается идеально!

Как решить сей баг?

С Уважением.
XerSon вне форума Ответить с цитированием
Старый 12.11.2010, 10:42   #2
XerSon
Форумчанин
 
Аватар для XerSon
 
Регистрация: 21.01.2008
Сообщений: 211
По умолчанию

Вроде сделал..
Код:
procedure OffClearType;
const
  SysParamFlags=SPIF_SENDWININICHANGE or SPIF_UPDATEINIFILE;
  RedrawFlags=RDW_INVALIDATE or RDW_ERASE or RDW_ALLCHILDREN
    or RDW_UPDATENOW or RDW_ERASENOW;
var
  SmoothingType:cardinal;
  WasCleartype:boolean;
begin
  SystemParametersInfo(SPI_GETFONTSMOOTHINGTYPE,0,@SmoothingType,0);
  WasCleartype:=SmoothingType=FE_FONTSMOOTHINGCLEARTYPE;
  if WasCleartype then
  begin
    SystemParametersInfo(SPI_SETFONTSMOOTHINGTYPE,0,
      pointer(FE_FONTSMOOTHINGSTANDARD),SysParamFlags);
    RedrawWindow(0,nil,0,RedrawFlags);
  end;
  // Make screenshot, etc.
  MessageBox(0,'Cleartype is disabled at this point...','Test',0);
  // Restore Cleartype state
  if WasCleartype then
  begin
    SystemParametersInfo(SPI_SETFONTSMOOTHINGTYPE,0,
      pointer(FE_FONTSMOOTHINGCLEARTYPE),SysParamFlags);
    RedrawWindow(0,nil,0,RedrawFlags);
  end;
end;
XerSon вне форума Ответить с цитированием
Старый 05.08.2017, 21:50   #3
ram555x
Пользователь
 
Регистрация: 08.02.2009
Сообщений: 16
По умолчанию

Привет, спасибо за код спустя 7 лет работает на win10, а кто нибудь знает как такое проделать, но только отдельно для приложения, чтобы только там отключался/включался cleartype, а то для всей системы долго он это делает.
ram555x вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как избежать сужения (уменьшение размера) пикселей изображения, при включенном свойстве Stretch? Лукманов Александр Мультимедиа в Delphi 8 26.10.2009 09:52
вывод текста при наведении на кнопку мимо Общие вопросы Delphi 3 04.07.2009 10:15
C|Вывод текста Troi666 Помощь студентам 4 09.05.2009 01:31
Включить ClearType для конкретного приложения MyasNick Win Api 1 05.05.2009 08:26
вывод текста Shkentik Общие вопросы Delphi 5 21.04.2009 23:29