Последние записи
- Изменить цвет шрифта TextBox на форме
- Ресайз PNG без потери прозрачности
- Вывод на печать графического файла
- Взаимодействие через командную строку
- Перенести программу из Delphi в Lazarus
- Определить текущую ОС
- Автоматическая смена языка (раскладки клавиатуры)
- Сравнение языков на массивах. Часть 2
- wprintf как напечатать кириллицу
- Взаимодействие через командную строку
Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk
Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw
13th
Мар
Как разрисовать HINTS
Posted by maloy under Заметки
blackstersl
Как можно разрисовать hints в своей программе? или компоненты есть для этого?
Alter
Из компонентов можно взять набор AlphaControl.
А вот ручная отрисовка, пример набросал(создание потомка от THintWindow):
unit HntUnit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Label1: TLabel;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
type TmyHint = class(THintWindow)
private
FActivating: Boolean;
FBmp, FBmp0 :TBitmap;
protected
procedure Paint; override;
function getBmp:TBitmap;
procedure SetBmp(B :TBitmap);
procedure Gradient(Col1, Col2: TColor; Bmp: TBitmap);
procedure DoDrawText(var Rect: TRect; Flags: Integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ActivateHint(Rect: TRect; const AHint: string); override;
published
property Caption;
property Picture:TBitmap read GetBmp write SetBmp;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TmyHint;
Application.ShowHint := True;
end;
{ TmyHint }
procedure TmyHint.ActivateHint(Rect: TRect; const AHint: string);
begin
FActivating := True;
try
Caption := AHint;
Inc(Rect.Bottom, 14); // отступ снизу
Rect.Right := Rect.Right + 20; // отступ справа
UpdateBoundsRect(Rect);
if Rect.Top + Height > Screen.DesktopHeight then
Rect.Top := Screen.DesktopHeight - Height;
if Rect.Left + Width > Screen.DesktopWidth then
Rect.Left := Screen.DesktopWidth - Width;
if Rect.Left < Screen.DesktopLeft then
Rect.Left := Screen.DesktopLeft;
if Rect.Bottom < Screen.DesktopTop then
Rect.Bottom := Screen.DesktopTop;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
SWP_SHOWWINDOW or SWP_NOACTIVATE);
Invalidate;
finally
FActivating := False;
end;
inherited;
end;
constructor TmyHint.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBmp := TBitmap.Create;
FBmp0 := TBitmap.Create;
with Canvas.Font do
begin
Name := 'Arial Narrow';
Size := 12;
Style := [fsBold];
Color := clLime;
end;
end;
destructor TmyHint.Destroy;
begin
FBmp.Free;
FBmp0.Free;
inherited Destroy;
end;
procedure TmyHint.DoDrawText(var Rect: TRect; Flags: Integer);
var
Text: string;
begin
Text := ' ' + Caption + ' ';
if (Flags and DT_CALCRECT <> 0) and (Text = '') then
Text := Text + ' ';
Flags := DrawTextBiDiModeFlags(Flags);
if not Enabled then
begin
OffsetRect(Rect, 1, 1);
Canvas.Font.Color := clBtnHighlight;
DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
OffsetRect(Rect, -1, -1);
Canvas.Font.Color := clBtnShadow;
DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end
else
DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end;
function TmyHint.getBmp: TBitmap;
begin
Result.Assign(FBmp);
end;
procedure TmyHint.Gradient(Col1, Col2: TColor; Bmp: TBitmap);
type
PixArray = array [1..3] of Byte;
var
i, big, rdiv, gdiv, bdiv, h, w: Integer;
ts: TStringList;
p: ^PixArray;
begin
rdiv := GetRValue(Col1) - GetRValue(Col2);
gdiv := GetgValue(Col1) - GetgValue(Col2);
bdiv := GetbValue(Col1) - GetbValue(Col2);
bmp.PixelFormat := pf24Bit;
for h := 0 to bmp.Height - 1 do
begin
p := bmp.ScanLine[h];
for w := 0 to bmp.Width - 1 do
begin
p^[1] := GetBvalue(Col1) - Round((w / bmp.Width) * bdiv);
p^[2] := GetGvalue(Col1) - Round((w / bmp.Width) * gdiv);
p^[3] := GetRvalue(Col1) - Round((w / bmp.Width) * rdiv);
Inc(p);
end;
end;
end;
procedure TmyHint.Paint;
var
R: TRect;
begin
R := ClientRect;
Inc(R.Left, 2);
Inc(R.Top, 2);
with Canvas do
begin
if Not FBmp.Empty then
Draw(2, (R.Bottom div 2) - (Fbmp.Height div 2), Fbmp)
else
begin
FBmp0.FreeImage;
with FBmp0 do
begin
Height := R.Bottom;
Width := R.Right;
end;
Gradient(clYellow, clRed, FBmp0);
Draw(0, 0, FBmp0)
end;
end;
Canvas.Brush.Style := bsClear;
DoDrawText(R, DT_EXPANDTABS);
end;
procedure TmyHint.SetBmp(B: TBitmap);
begin
FBmp.FreeImage;
FBmp.Assign(B);
Invalidate;
end;
procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Memo1.Hint := Memo1.Text;
end;
end.
тема на форуме от 2009 года
Похожие статьи
Купить рекламу на сайте за 1000 руб
пишите сюда - alarforum@yandex.ru
Да и по любым другим вопросам пишите на почту
пеллетные котлы
Пеллетный котел Emtas
Наши форумы по программированию:
- Форум Web программирование (веб)
- Delphi форумы
- Форумы C (Си)
- Форум .NET Frameworks (точка нет фреймворки)
- Форум Java (джава)
- Форум низкоуровневое программирование
- Форум VBA (вба)
- Форум OpenGL
- Форум DirectX
- Форум CAD проектирование
- Форум по операционным системам
- Форум Software (Софт)
- Форум Hardware (Компьютерное железо)