• Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?
• Как заполнить Canvas рисунком с рабочего стола, учитывая координаты.
• Как изменить вид ListBox (вставить изображения, изменить шрифт отдельных элеметов и т.п.) ?
• Как из программы на Delphi рисовать в любой части экрана или в чужом окне?
• Написание текста под углом
• Преобразование цвета RGB в HLS (оттенок,яркость,насыщенность) и наоборот
• Как определить число цветов для текущих настроек экрана
• Как скопировать экран (или часть экрана) ?
• Отображение текста со стилем "disabled" (характерный серый контурный текст)
• Как изменять разрешение экрана во время выполнения программы
• Как поместить картинку из базы данных в компонент TIMAGE ?
• Как установить произвольный цвет, зная его RGB

• Работа с регионами
• Создание регионов
• Назначение региона окну

Общие вопросы

Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?

*

*

procedure TMain.BitBtnClick(Sender: TObject);
var
  Palette : HPalette;
  PaletteSize : Integer;
  LogSize: Integer;
  LogPalette: PLogPalette;
  Red : Byte;
begin
  Palette := Image.Picture.Bitmap.ReleasePalette;
  // здесь можно использовать просто Image.Picture.Bitmap.Palette, но  я не
  // знаю, удаляются ли ненужные палитры автоматически

  if Palette=0 then exit; //Палитра отсутствует
  PaletteSize := 0;
  if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  // Количество элементов в палитре = paletteSize
  if PaletteSize = 0 then Exit; // палитра пустая
  // определение размера палитры
  LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
  GetMem(LogPalette, LogSize);
  try
    // заполнение полей логической палитры
    with LogPalette^ do begin
      palVersion := $0300;    palNumEntries := PaletteSize;
      GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
      // делаете что нужно с палитрой, например:
      Red := palPalEntry[PaletteSize-1].peRed;
      Edit1.Text := 'Красная составляющего последнего элемента  палитры ='+IntToStr(Red);
      palPalEntry[PaletteSize-1].peRed := 0;
      //.......................................
    end;
    // завершение работы
    Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);
  finally
    FreeMem(LogPalette, LogSize);
    // я должен позаботиться сам об удалении Released Palette
    DeleteObject(Palette);
  end;
end;


{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов) 
  и меняет его палитру при нажатии кнопки }
unit bmpformu;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TBmpForm = class(TForm)
    Button1: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    Bitmap: TBitmap;
    procedure ScrambleBitmap;
    procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
end;

var
  BmpForm: TBmpForm;

implementation
{$R *.DFM}
procedure TBmpForm.FormCreate(Sender: TObject);
begin
  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile('bor6.bmp');
end;

procedure TBmpForm.FormDestroy(Sender: TObject);
begin
  Bitmap.Free;
end;

// since we're going to be painting the whole form, handling this
// message will suppress the uneccessary repainting of the background
// which can result in flicker.
procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
  m.Result := LRESULT(False);
end;

procedure TBmpForm.FormPaint(Sender: TObject);
var x, y: Integer;
begin
  y := 0;
  while y < Height do begin
    x := 0;
    while x < Width do begin
      Canvas.Draw(x, y, Bitmap);
      x := x + Bitmap.Width;
    end;
    y := y + Bitmap.Height;
  end;
end;

procedure TBmpForm.Button1Click(Sender: TObject);
begin
  ScrambleBitmap; Invalidate;
end;

// scrambling the bitmap is easy when it's has 256 colors:
// we just need to change each of the color in the palette
// to some other value.
procedure TBmpForm.ScrambleBitmap;
var
  pal: PLogPalette;
  hpal: HPALETTE;
  i: Integer;
begin
  pal := nil;
  try
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    pal.palVersion := $300;
    pal.palNumEntries := 256;
    for i := 0 to 255 do
    begin
      pal.palPalEntry[i].peRed := Random(255);
      pal.palPalEntry[i].peGreen := Random(255);
      pal.palPalEntry[i].peBlue := Random(255);
    end;
    hpal := CreatePalette(pal^);
    if hpal <> 0 then
      Bitmap.Palette := hpal;
  finally
    FreeMem(pal);
  end;
end;

end.

Как заполнить Canvas рисунком с рабочего стола, учитывая координаты.

*

*

Для заполнения Canvas рисунком с рабочего стола неоьходимо использовать вызов API Function PaintDesktop(HDC) : boolean;
Например: PaintDesktop(form1.Canvas.Handle);

Как изменить вид ListBox (вставить изображения, изменить шрифт отдельных элеметов и т.п.) ?

*

*

Для вставки растровых изображений в ListBox необходимо установить в инспекторе объектов поле Style равным lbOwnerDrawFixed (при фиксированной высоте строки), или в lbOwnerDrawVariable (при переменной). Затем следует создать собственный обработчик события для OnDrawItem. Этот обработчик вызывается всякий раз, когда возникает необходимость в отрисовке элемента списка.
Обработчик имеет вид

ListBox1DrawItem(Control: TWinControl; Index: Integer; 
           Rect: TRect; State: DrawState); 

// Загрузить список файлов в ListBox1 при нажатии на кнопку Load (например)
procedure TForm1.bLoadClick(Sender: TObject);
VAR S : String; 
begin 
  ListBox1.Clear; // Очистка списка
  S := '*.bmp'#0; // Определение шаблона
  // Заполнение списка 
  ListBox1.Perform(LB_DIR, DDL_ReadWrite, Longint(@S[1])); 
end; 
          ............ 

// Отобразжение Элемента списка
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; 
           Rect: TRect; State: DrawState); 
VAR 
  Bitmap : TBitmap; // Картинка
  Offset : Integer; 
  BMPRect: TRect; 
begin 
  WITH (Control AS TListBox).Canvas DO BEGIN 
    FillRect(Rect); 
    Bitmap := TBitmap.Create;
    // Попытка загрузки картинки
    Bitmap.LoadFromFile(ListBox1.Items[Index]); 
    Offset := 0; 
    // Загрузилась ?
    IF Bitmap <> NIL THEN BEGIN 
      BMPRect := Bounds(Rect.Left+2, Rect.Top+2, 
                        (Rect.Bottom-Rect.Top-2)*2, Rect.Bottom-Rect.Top-2); 
      { StretchDraw(BMPRect, Bitmap); Можно просто нарисовать, но лучше сначала убрать фон} 
      BrushCopy(BMPRect,Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
                Bitmap.Canvas.Pixels[0, Bitmap.Height-1]); 
      Offset := (Rect.Bottom-Rect.Top+1)*2; 
    END; 
    // Вывод текста элемента
    TextOut(Rect.Left+Offset, Rect.Top, ListBox1.Items[Index]); 
    Bitmap.Free; 
   END; 
end; 

Как из программы на Delphi рисовать в любой части экрана или в чужом окне?

*

*

Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана можно при помощи функции function GetDC(Wnd: HWnd): HDC;
где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана.
Затем, получив контекст, можно приступить к рисованию посредством функций API
Пример:

PROCEDURE DrawOnScreen; 
VAR ScreenDC: hDC; 
BEGIN 
  ScreenDC := GetDC(0); // получить контекст экрана
  Ellipse(ScreenDC, 0, 0, 200, 200); // Нарисовали круг
  ReleaseDC(0,ScreenDC); // освободили контекст
END; 

Написание текста под углом

*

*

В Delphi можно достаточно просто выводить текст под любым углом, единственное условие - применяемый шрифт должен быть TrueType

// Эта процедура устанавливает угол вывода текста для указанного Canvas, 
// угол задается в градусах
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var   LogRec: TLOGFONT;     // Информация о шрифте
begin
 // Читаем текущюю информацию о шрифте
 GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
 // Изменяем угол
 LogRec.lfEscapement := round(d*10);
 // Устанавливаем новые параметры
 c.Font.Handle := CreateFontIndirect(LogRec);
end;

Преобразование цвета RGB в HLS (оттенок,яркость,насыщенность) и наоборот

*

*

{ Максимальные значения }
Const
 HLSMAX = 240;
 RGBMAX = 255;
 UNDEFINED = (HLSMAX*2) div 3;
Var
 H, L, S  : integer; { H-оттенок, L-яркость, S-насыщенность }
 R, G, B  : integer; { цвета }

procedure RGBtoHLS;
Var
 cMax,cMin  : integer;
 Rdelta,Gdelta,Bdelta : single;
Begin
   cMax := max( max(R,G), B);
   cMin := min( min(R,G), B);
   L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );

   if (cMax = cMin) then begin
      S := 0; H := UNDEFINED;
   end else begin
      if (L <= (HLSMAX/2)) then
         S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
      else
         S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
            / (2*RGBMAX-cMax-cMin) );
      Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
      if (R = cMax) then H := round(Bdelta - Gdelta)
      else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)
      else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
      if (H < 0) then H:=H + HLSMAX;
      if (H > HLSMAX) then H:= H - HLSMAX;
   end;
   if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
   if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;


procedure HLStoRGB;
Var
 Magic1,Magic2 : single;

  function HueToRGB(n1,n2,hue : single) : single;
  begin
     if (hue < 0) then hue := hue+HLSMAX;
     if (hue > HLSMAX) then hue:=hue -HLSMAX;
     if (hue < (HLSMAX/6)) then
        result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
     else
     if (hue < (HLSMAX/2)) then result:=n2 else
     if (hue < ((HLSMAX*2)/3)) then
        result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
     else result:= ( n1 );
  end;

begin
   if (S = 0) then begin
      B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
   end else begin
      if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
      else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
      Magic1 := 2*L-Magic2;
      R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
      G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
      B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
   end;
   if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
   if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
   if B<0 then B:=0; if B>RGBMAX then B:=RGBMAX;
end;

Как определить число цветов для текущих настроек экрана

*

*

Определить число цветов для текущих настроек экрана достаточно просто при помощи функции API GetDeviceCaps. Например, описанная ниже функция возвращает число бит на точку у данного компьютера. Так, например, 8 - 8 бит (256 цветов), 4 - 4 бит (16 цветов) и т.п. Напоминаю, что число цветов легко получить как 2^N, где N - число бит на точку.

function GetDisplayColors : integer;
var tHDC  : hdc;
begin
 tHDC:=GetDC(0);
 result:=GetDeviceCaps(tHDC, 12)* GetDeviceCaps(tHDC, 14);
 ReleaseDC(0, tHDC);
end;

Как скопировать экран (или часть экрана) ?

*

*

Копирование экрана легко произвести при помощи функций API. Приведенная ниже библиотека позволит упростить эту операцию

unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

// Копирует прямоугольную область экрана
function CaptureScreenRect(ARect : TRect) : TBitmap;
// Копирование всего экрана
function CaptureScreen : TBitmap;
// Копирование клиентской области формы или элемента
function CaptureClientImage(Control : TControl) : TBitmap;
// Копирование всей формы элемента
function CaptureControlImage(Control : TControl) : TBitmap;

implementation
// Получение системной палитры
function GetSystemPalette : HPalette;
var
 PaletteSize  : integer;
 LogSize      : integer;
 LogPalette   : PLogPalette;
 DC           : HDC;
 Focus        : HWND;
begin
 result:=0;
 Focus:=GetFocus;
 DC:=GetDC(Focus);
 try
   PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
   LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
   GetMem(LogPalette, LogSize);
   try
     with LogPalette^ do
     begin
       palVersion:=$0300;
       palNumEntries:=PaletteSize;
       GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
     end;
     result:=CreatePalette(LogPalette^);
   finally
     FreeMem(LogPalette, LogSize);
   end;
 finally
   ReleaseDC(Focus, DC);
 end;
end;

// Копирование прямоугольной области
function CaptureScreenRect(ARect : TRect) : TBitmap;
var
 ScreenDC : HDC;
begin
 Result:=TBitmap.Create;
 with result, ARect do begin
  Width:=Right-Left;
  Height:=Bottom-Top;
  ScreenDC:=GetDC(0);
  try
    BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY	);
  finally
    ReleaseDC(0, ScreenDC);
  end;
  Palette:=GetSystemPalette;
 end;
end;

// Копирование всего экрана
function CaptureScreen : TBitmap;
begin
 with Screen do
  Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;

function CaptureClientImage(Control : TControl) : TBitmap;
begin
 with Control, Control.ClientOrigin do
  result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;

function CaptureControlImage(Control : TControl) : TBitmap;
begin
 with Control do
  if Parent=Nil then
    result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
  else
   with Parent.ClientToScreen(Point(Left, Top)) do
    result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.

Отображение текста со стилем "disabled" (характерный серый контурный текст)

*

*

{************************ Draw Disabled Text **************
 ***** This function draws text in "disabled" style.  *****
 ***** i.e. the text is grayed .                      *****
 **********************************************************}
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
                           var Rect: TRect;  Format: Word): Integer;
begin
  SetBkMode(Canvas.Handle, TRANSPARENT);

  OffsetRect(Rect, 1, 1);
  Canvas.Font.color:= ClbtnHighlight;
  DrawText (Canvas.Handle, Str, Count, Rect,Format);

  Canvas.Font.Color:= ClbtnShadow;
  OffsetRect(Rect, -1, -1);
  DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;

Как изменять разрешение экрана во время выполнения программы

*

*

// Переход в полноэкранный режим
function SetFullscreenMode:Boolean;
var DeviceMode : TDevMode;
begin
 with DeviceMode do begin
  dmSize:=SizeOf(DeviceMode);
  dmBitsPerPel:=16;
  dmPelsWidth:=640;
  dmPelsHeight:=480;
  dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
  result:=False;
  if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL 
   then Exit;
  Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;
 end;
end;

// Возврат в исходный режим
procedure RestoreDefaultMode;
var T : TDevMode absolute 0;
begin
 ChangeDisplaySettings(T,CDS_FULLSCREEN);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 if setFullScreenMode then begin
  sleep(7000);
  RestoreDefaultMode;
 end;
end;

Как поместить картинку из базы данных в компонент TIMAGE ?

*

*

1) Предполагается, что поле имеет тип BLOB (например, с именем Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

Как установить произвольный цвет, зная его RGB

*

*

Самый простой путь - присвоение значения свойству Color, которое представляет собой значение LongInt, байты которого кодируют цвета в следующем порядке BGR. Пример - установка красного цвета - Color := $0000FF. Причем обычно принято писать незначащие нули - это упрощает чтение и понимание принципа кодирования

© Зайцев Олег, "Программирование на Delphi - обмен опытом" 1999-2004. При использовании любых материалов данного сайта необходимо указывать источник информации. Дата обновления: 22.11.2004. Сайт размещен на хостинге AGAVA - Хостинг от AGAVA.ru