Виртуальная библиотека Delphi - [14]

   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;

Число цветов (цветовая палитра) у данного компьютера

Эта функция возвращает число бит на точку у данного компьютера. Так, например, 8 — 256 цветов, 4 — 16 цветов ...

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

Копирование экрана

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.

Как нарисовать "неактивный"(disable) текст.

{************************ 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;