var
  Bmp: TBitmap;

// Вычисление множителя для масштабирования картинки (миниатюры)
// SourceWidth, SourceHeight - размеры исходного изображения
// PreviewWidth, PreviewHeight - размеры, в которые изображение нужно вписать
function CalcFactor(SourceWidth, SourceHeight, PreviewWidth, PreviewHeight: Integer): Double;
begin
  if (PreviewWidth < SourceWidth) or (PreviewHeight < SourceHeight) then
    Result := Min(PreviewWidth / SourceWidth, PreviewHeight / SourceHeight)
  else
    Result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Factor: Double;
  NewWidth, NewHeight: Integer; 
begin
  // Допустим в переменной Bmp: TBitmap хранится изображение,
  // для которого нужно вычислить размер его миниатюры
  Factor := CalcFactor(Bmp.Width, Bmp.Height, 100, 100);
  NewWidth := Round(Factor * Bmp.Width); // Ширина миниатюры
  NewHeight := Round(Factor * Bmp.Height); // Высота миниатюры
end;

// Способ первый
{$IFDEF UNICODE}
  function PrivateExtractIcons(lpszFile: PChar; nIconIndex, cxIcon, cyIcon: integer; phicon: PHANDLE; piconid: PDWORD; nicon, flags: DWORD): DWORD;
    stdcall ; external 'user32.dll' name 'PrivateExtractIconsW';
{$ELSE}
  function PrivateExtractIcons(lpszFile: PChar; nIconIndex, cxIcon, cyIcon: integer; phicon: PHANDLE; piconid: PDWORD; nicon, flags: DWORD): DWORD;
    stdcall ; external 'user32.dll' name 'PrivateExtractIconsA';
{$ENDIF}

function ExtractIcons(SourceFile: string; IconIndex, cxIcon, cyIcon: Integer;
  TargetFile: string): Boolean;
var
  hIcon: THandle;
  nIconId: DWORD;
  Icon: TIcon;
begin
  Result := False;
  if PrivateExtractIcons( PWideChar( SourceFile ), IconIndex, cxIcon, cyIcon, @hIcon,
    @nIconId, 1, LR_LOADFROMFILE ) <> 0 then

  try
    Icon := TIcon.Create;
    try
      Icon.Handle := hIcon;
      Icon.SaveToFile(TargetFile);
      Result := True;
    finally
      Icon.Free;
    end;
  finally
    DestroyIcon(hIcon);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if ExtractIcons('Shell32.dll', 15, 256, 256, 'c:\SavedIcon.ico') then
      ShowMessage('Иконка сохранена.');
end;

// Способ второй
uses
  {...,} ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Icon.Handle :=
    ExtractIcon(HInstance, PChar('c:\Windows\explorer.exe'), 0);
end;

// Способ третий
uses
  {...,} ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
const
  FileName = 'c:\Windows\explorer.exe';
var
 Icon: TIcon;
 Icon32, Icon16: HICON;
 i: Integer;
begin
  try
    // Так можно получить количество иконок в файле
    // ExtractIconEx(PChar(FileName), -1, Icon16, Icon32, 0);
    i := 0;
    while Integer(ExtractIconEx(PChar(FileName), i, Icon16, Icon32, 1)) > 0 do
    begin
      Icon := TIcon.Create;
      Icon.Handle := Icon32;
      ImageList1.AddIcon(Icon);
      Icon.Free;
      Inc(i);
    end;
  except
    on e: Exception do
      //
  end;
end;

uses
  {...,} Math;

type
  TForm1 = class(TForm)
    Button1: TButton;
    imMain: TImage;
    procedure Button1Click(Sender: TObject);
  private
  public
  end;

implementation

procedure DrawDisk( Bitmap: TBitmap; CenterX, CenterY, Radius, Feather: Single );
// Draw a disk on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap,
// and parts outside the disk will get palette index 0, parts inside will get
// palette index 255, and in the antialiased area (feather), the pixels will
// get values inbetween.
// ***Parameters***
// Bitmap:
//   The bitmap to draw on
// CenterX, CenterY:
//   The center of the disk (float precision). Note that [0, 0] would be the
//   center of the first pixel. To draw in the exact middle of a 100x100 bitmap,
//   use CenterX = 49.5 and CenterY = 49.5
// Radius:
//   The radius of the drawn disk in pixels (float precision)
// Feather:
//   The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers
//   outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2'
//   become 255. Using a value of 0 will yield a bilevel image.
// Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl
var
  x, y: Integer;
  LX, RX, LY, RY: Integer;
  Fact: Integer;
  RPF2, RMF2: Single;
  P: PByteArray;
  SqY, SqDist: Single;
  sqX: array of Single;
begin
  // Determine some helpful values (singles)
  RPF2 := Sqr(Radius + Feather/2);
  RMF2 := Sqr(Radius - Feather/2);

  // Determine bounds:
  LX := Max(Floor(CenterX - RPF2), 0);
  RX := Min(Ceil(CenterX + RPF2), Bitmap.Width - 1);
  LY := Max(Floor(CenterY - RPF2), 0);
  RY := Min(Ceil(CenterY + RPF2), Bitmap.Height - 1);

  // Optimization run: find squares of X first
  SetLength(SqX, RX - LX + 1);
  for x := LX to RX do
    SqX[x-LX] := Sqr(x - CenterX);

  // Loop through Y values
  for y := LY to RY do
  begin
    P := Bitmap.Scanline[y];
    SqY := Sqr(y - CenterY);
    // Loop through X values
    for x := LX to RX do
    begin
      // determine squared distance from center for this pixel
      SqDist := SqY + SqX[x - LX];

      // inside inner circle? Most often..
      if sqdist < RMF2 then
      begin
        // inside the inner circle.. just give the scanline the new color
        P[x] := 255
      end
      else
      begin
        // inside outer circle?
        if sqdist < RPF2 then
        begin
          // We are inbetween the inner and outer bound, now mix the color
          Fact := Round(((Radius - Sqrt(SqDist)) * 2 / Feather) * 127.5 + 127.5);
          P[x] := Max(0, Min(Fact, 255)); // just in case limit to [0, 255]
        end
        else
          P[x] := 0;
      end;
    end;
  end;
end;

procedure DrawCircle(Bitmap: TBitmap; CenterX, CenterY, Radius, LineWidth, Feather: Single);
// Draw a circle on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap,
// and parts outside the circle will get palette index 0, parts inside will get
// palette index 255, and in the antialiased area (feather), the pixels will
// get values inbetween.
// ***Parameters***
// Bitmap:
//   The bitmap to draw on
// CenterX, CenterY:
//   The center of the circle (float precision). Note that [0, 0] would be the
//   center of the first pixel. To draw in the exact middle of a 100x100 bitmap,
//   use CenterX = 49.5 and CenterY = 49.5
// Radius:
//   The radius of the drawn circle in pixels (float precision)
// LineWidth
//   The line width of the drawn circle in pixels (float precision)
// Feather:
//   The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers
//   outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2'
//   become 255. Using a value of 0 will yield a bilevel image. Note that Feather
//   must be equal or smaller than LineWidth (or it will be adjusted internally)
// Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl
var
  x, y: Integer;
  LX, RX, LY, RY: Integer;
  Fact: Integer;
  ROPF2, ROMF2, RIPF2, RIMF2: Single;
  OutRad, InRad: Single;
  P: PByteArray;
  SqY, SqDist: Single;
  sqX: array of Single;
begin
  // Determine some helpful values (singles)
  OutRad := Radius + LineWidth/2;
  InRad  := Radius - LineWidth/2;
  ROPF2 := Sqr(OutRad + Feather/2);
  ROMF2 := Sqr(OutRad - Feather/2);
  RIPF2 := Sqr(InRad  + Feather/2);
  RIMF2 := Sqr(InRad  - Feather/2);

  // Determine bounds:
  LX := Max(Floor(CenterX - ROPF2), 0);
  RX := Min(Ceil(CenterX + ROPF2), Bitmap.Width - 1);
  LY := Max(Floor(CenterY - ROPF2), 0);
  RY := Min(Ceil(CenterY + ROPF2), Bitmap.Height - 1);

  // Checks
  if Feather > LineWidth then
    Feather := LineWidth;

  // Optimization run: find squares of X first
  SetLength(SqX, RX - LX + 1);
  for x := LX to RX do
    SqX[x - LX] := Sqr(x - CenterX);

  // Loop through Y values
  for y := LY to RY do
  begin
    P := Bitmap.Scanline[y];
    SqY := Sqr(y - CenterY);
    // Loop through X values
    for x := LX to RX do
    begin
      // determine squared distance from center for this pixel
      SqDist := SqY + SqX[x - LX];

      // now first check if we're completely inside (most often)
      if SqDist < RIMF2 then
      begin
        // We're on the disk inside everything
        P[x] := 0;
      end
      else
      begin
        // completely outside?
        if SqDist < ROPF2 then
        begin
          // inside outer line - feather?
          if SqDist < ROMF2 then
          begin
            // check if we're in inside feather area
            if SqDist < RIPF2 then
            begin
              // We are in the feather area of inner line, now mix the color
              Fact := Round(((Sqrt(SqDist) - InRad) * 2 / Feather) * 127.5 + 127.5);
              P[x] := Max(0, Min(Fact, 255)); // just in case limit to [0, 255]
            end
            else
            begin
              // on the line
              P[x] := 255;
            end;
          end
          else
          begin
            // We are in the feather area of outer line, now mix the color
            Fact := Round(((OutRad - Sqrt(SqDist)) * 2 / Feather) * 127.5 + 127.5);
            P[x] := Max(0, Min(Fact, 255)); // just in case limit to [0, 255]
          end;
        end
        else
        begin
          // outside everything
          P[x] := 0;
        end;
      end;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
// Create a 256-color bitmap and call the DrawCircle procedure
var
  i, y: Integer;
  ABitmap: TBitmap;
  pal: PLogPalette;
  hpal: HPALETTE;
  ColRGB, BgrRGB: Integer;
  ACenterX, ACenterY,
  ARadius, AFeather,
  ALineWidth: Single;
begin
  ABitmap := TBitmap.Create;
  try
    // 8 bits per pixel
    ABitmap.PixelFormat := pf8bit;

    // Set width and height
    ABitmap.Width := 300;
    ABitmap.Height := 300;

    // Create a gradient palette between foreground and background color
    GetMem(pal, SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 255);
    try
      pal.palVersion := $300;
      pal.palNumEntries := 256;
      ColRGB := ColorToRGB(clWhite);
      BgrRGB := ColorToRGB(clBlack);

      for i := 0 to 255 do
      begin
        pal.palPalEntry[i].peRed := Round(i / 255 * (ColRGB and $FF) + (255 - i) / 255 * (BgrRGB and $FF));
        pal.palPalEntry[i].peGreen := Round(i / 255 * (ColRGB shr 8 and $FF) + (255 - i) / 255 * (BgrRGB shr 8 and $FF));
        pal.palPalEntry[i].peBlue := Round(i / 255 * (ColRGB shr 16 and $FF) + (255 - i) / 255 * (BgrRGB shr 16 and $FF));
      end;
      hpal := CreatePalette(pal^);
      if hpal <> 0 then
        ABitmap.Palette := hpal;
    finally
      FreeMem(pal);
    end;

    // Fill bitmap with background color
    for y := 0 to ABitmap.Height-1 do
      FillChar(ABitmap.Scanline[y]^, ABitmap.Width, 0);

    // Get data from form
    ACenterX := 150;
    ACenterY := 150;
    ARadius := 135.5;
    ALineWidth := 10;
    AFeather := 5;

    // Рисуем диск
    DrawDisk(ABitmap, ACenterX, ACenterY, ARadius, AFeather);
    // Рисуем окружность
    // DrawCircle(ABitmap, ACenterX, ACenterY, ARadius, ALineWidth, AFeather);

    // Assign to image
    imMain.Picture.Bitmap.Assign(ABitmap);
  finally
    ABitmap.Free;
  end;
end;

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    Mask: TBitmap;
  public
  end;


implementation

procedure TForm1.FormCreate(Sender: TObject);
var
  IconInfo: TIconInfo;
begin
  Mask := TBitmap.Create;
  GetIconInfo(Application.Icon.Handle, IconInfo);
  Mask.Handle := IconInfo.hbmMask;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Mask.Free;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  BitBlt(Canvas.Handle, 0, 0, Mask.Width, Mask.Height,
         Mask.Canvas.Handle, 0, 0, SRCCOPY);
end;

uses
  {...,} Math;

procedure PlotPolygon(const Canvas: TCanvas; const N: Integer; const R: Single;
  const XC: Integer; const YC: Integer);
type
  TPolygon = array of TPoint;
var
  Polygon: TPolygon;
  I: Integer;
  C: Extended;
  S: Extended;
  A: Single;
begin
  SetLength(Polygon, N);
  A := 2 * Pi / N;
  for I := 0 to (N - 1) do
  begin
    SinCos(I * A, S, C);
    Polygon[I].X := XC + Round(R * C);
    Polygon[I].Y := YC + Round(R * S);
  end;
  Canvas.Polygon(Polygon);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W: Single;
  H: Single;
  X: Integer;
  Y: Integer;
const
  N = 6;
  R = 10;
begin
  W := 1.5 * R;
  H := R * Sqrt(3);
  for X := 0 to Round(ClientWidth / W) do
    for Y := 0 to Round(ClientHeight / H) do
      if Odd(X) then
        PlotPolygon(Canvas, N, R, Round(X * W), Round((Y + 0.5) * H))
      else
        PlotPolygon(Canvas, N, R, Round(X * W), Round(Y * H));
end;

procedure ExtFont(Canvas: TCanvas);
var
  Font: HFONT;
  FontName, Txt: PChar;
  sSize: Size;
  i: Integer;
  Obj: LongWord;
begin
  FontName := 'Tahoma';
  Txt := 'www.decoding.dax.ru';
  Font := CreateFont(60, 30, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET,
                     OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
                     PROOF_QUALITY, DEFAULT_PITCH + FF_DONTCARE, FontName);
  Obj := SelectObject(Canvas.Handle, Font);
  SetBkMode(Canvas.Handle, TRANSPARENT);
  GetTextExtentPoint32(Canvas.Handle, Txt, Length(Txt), sSize);
  BeginPath(Canvas.Handle);
  Canvas.Pen.Color:= clGreen; // Цвет текста
  i := 1;
  for i := 0 to 2 do  // Глубина эффекта
    // Позиция текста на форме
    TextOut(Canvas.Handle, 5 + i, 10 + i, Txt, Length(Txt));
  EndPath(Canvas.Handle);
  // Canvas.Pen.Style := psDot; { Стиль }
  StrokePath(Canvas.Handle);
  SetBkMode(Canvas.Handle, OPAQUE);
  DeleteObject(Obj);
  DeleteObject(Font);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  ExtFont(Canvas);
end;

// Способ первый
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
function PixelsToMM(WidthInPixels: Cardinal): Extended;
begin
  Result := WidthInPixels / Screen.PixelsPerInch * 25.4;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(FloatToStr(PixelsToMM(10)));
end;

// Способ второй
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
procedure PixelsToMM(DC: HDC; WidthInPixels: Cardinal;
  var WidthInMM, HeightInMM: Extended);
begin
  WidthInMM := WidthInPixels * 25.4 / GetDeviceCaps(DC, LOGPIXELSX);
  HeightInMM := WidthInPixels * 25.4 / GetDeviceCaps(DC, LOGPIXELSY);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  WidthInMM, HeightInMM: Extended;
begin
  PixelsToMM(GetDC(HWND(nil) {0}), 10, WidthInMM, HeightInMM);
  ShowMessage('W: ' + FloatToStr(WidthInMM) + '   H: ' + FloatToStr(HeightInMM));
end;

// Способ третий
// Имеет бОльшую точность
procedure PixelsToMM(DC: HDC; WidthInPixels, HeightInPixels: Cardinal;
  var WidthInMM, HeightInMM: Extended);
var
  HRes, VRes, HSiz, VSiz: Integer;
begin
  HRes := GetDeviceCaps(DC, HORZRES);
  VRes := GetDeviceCaps(DC, VERTRES);
  HSiz := GetDeviceCaps(DC, HORZSIZE);
  VSiz := GetDeviceCaps(DC, VERTSIZE);
  WidthInMM := WidthInPixels / (HRes / HSiz);
  HeightInMM := HeightInPixels / (VRes / VSiz);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  WidthInMM, HeightInMM: Extended;
begin
  PixelsToMM(GetDC(HWND(nil) {0}), 10, 10, WidthInMM, HeightInMM);
  ShowMessage('W: ' + FloatToStr(WidthInMM) + '   H: ' + FloatToStr(HeightInMM));
end;

// Способ первый
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
function MMToPixels(WidthInMM: Extended): Cardinal;
begin
  Result := Round(Screen.PixelsPerInch / 25.4 * WidthInMM);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  ShowMessage(IntToStr(MMToPixels(2.64583333333333)));
end;

// Способ второй
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
procedure MMToPixels( DC: HDC; WidthInMM: Extended;
  var WidthInPixels, HeightInPixels: Cardinal );
begin
  WidthInPixels := Round(GetDeviceCaps(DC, LOGPIXELSX) / 25.4 * WidthInMM);
  HeightInPixels := Round(GetDeviceCaps(DC, LOGPIXELSY) / 25.4 * WidthInMM);
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  WidthInPixels, HeightInPixels: Cardinal;
begin
  MMToPixels(GetDC(HWND(nil) {0}), 2.64583333333333, WidthInPixels, HeightInPixels);
  ShowMessage('W: ' + IntToStr(WidthInPixels) + '   H: ' + IntToStr(HeightInPixels));
end;

// Способ третий
// Имеет бОльшую точность
procedure MMToPixels(DC: HDC; WidthInMM, HeightInMM: Extended;
  var WidthInPixels, HeightInPixels: Cardinal);
var
  HRes, VRes, HSiz, VSiz: Integer;
begin
  HRes := GetDeviceCaps(DC, HORZRES);
  VRes := GetDeviceCaps(DC, VERTRES);
  HSiz := GetDeviceCaps(DC, HORZSIZE);
  VSiz := GetDeviceCaps(DC, VERTSIZE);
  WidthInPixels := Round(WidthInMM * (HRes / HSiz));
  HeightInPixels := Round(HeightInMM * (VRes / VSiz));
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  WidthInPixels, HeightInPixels: Cardinal;
begin
  MMToPixels(GetDC(HWND(nil) {0}), 3.52604166666667, 3.52777777777778, WidthInPixels, HeightInPixels);
  ShowMessage('W: ' + IntToStr(WidthInPixels) + '   H: ' + IntToStr(HeightInPixels));
end;

uses
  Math;

const
  C1: TColor = clRed;
  C2: TColor = clLime;

function getNearestColor(const aColor1, aColor2: TColor; const aRate: Single): TColor;
var
  r, r1,
  g, g1,
  b, b1: Byte;
begin
  Assert((aRate >= 0) and (aRate <= 100), 'Изменение цвета должно быть меньше 100% разницы цветов');
  // Раскладываем цвета на компоненты
  r := GetRValue(aColor2);
  g := GetGValue(aColor2);
  b := GetBValue(aColor2);
  r1 := GetRValue(aColor1);
  g1 := GetGValue(aColor1);
  b1 := GetBValue(aColor1);
  Result:= RGB(r1 - Floor((r1 - r) * (aRate / 100)),
               g1 - Floor((g1 - g) * (aRate / 100)),
               b1 - Floor((b1 - b) * (aRate / 100)));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Canvas.Brush.Color := getNearestColor(C1, C2, 50);
  Canvas.FillRect(ClientRect);
end;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    Image5: TImage;
    Image6: TImage;
    Image7: TImage;
    Image8: TImage;
    Image9: TImage;
    Image10: TImage;
    procedure FormCreate(Sender: TObject);
  private
    GradArr: array[1..10] of TColor;
  public
  end;

implementation

uses
  Math;

function GetColorInterval(Color1, Color2: TColor; IntervalCount, IntervalIndex: Byte): TColor;
const
  STEP = 256;
var
  // Компоненты цвета
  r1, r2,
  g1, g2,
  b1, b2: Byte;
begin
  r1 := GetRValue(Color1);
  g1 := GetGValue(Color1);
  b1 := GetBValue(Color1);

  r2 := GetRValue(Color2);
  g2 := GetGValue(Color2);
  b2 := GetBValue(Color2);

  Result := RGB(Byte(Floor(r1 + (r2 - r1) * Trunc(STEP / (IntervalCount + 1) * IntervalIndex) / STEP)),
                Byte(Floor(g1 + (g2 - g1) * Trunc(STEP / (IntervalCount + 1) * IntervalIndex) / STEP)),
                Byte(Floor(b1 + (b2 - b1) * Trunc(STEP / (IntervalCount + 1) * IntervalIndex) / STEP)));
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  Img: TImage;
begin
  GradArr[1] := clYellow; // Начальный цвет
  GradArr[10] := clRed;   // Конечный цвет

  for i := 1 to 8 do // Нам нужно 8 градаций
    GradArr[i+1] := GetColorInterval(GradArr[1], GradArr[10], 8, i);

  for i := 1 to 10 do
  begin
    Img := TImage(FindComponent('Image' + IntToStr(i)));
    if Assigned(Img) then
    begin
      Img.Canvas.Brush.Color := GradArr[i];
      Img.Canvas.FillRect(Rect(0, 0, Img.Width, Img.Height));
    end;
  end;
end;