Вращение изображения

Материал из DRKB


Поворот на 90 градусов[править | править код]

Вот быстрый и примитивный способ вращения изображения. Должно работать. По крайней мере хоть какой-то выход из-положения, поскольку Windows этого делать не умеет. Но сначала попробуйте на небольших изображениях.

procedure RotateRight(BitMap: TImage);
var
  FirstC, LastC, c, r: Integer;

  procedure FixPixels(c, r: Integer);
  var
    SavePix, SavePix2: TColor;
    i, NewC, NewR: Integer;
  begin
    SavePix := Bitmap.Canvas.Pixels[c, r];
    for i := 1 to 4 do
    begin
      NewC := BitMap.Height - r + 1;
      NewR := c;
      SavePix2 := BitMap.Canvas.Pixels[NewC, NewR];
      Bitmap.Canvas.Pixels[NewC, NewR] := SavePix;
      SavePix := SavePix2;
      c := NewC;
      r := NewR;
    end;
  end;

begin
  if BitMap.Width <> BitMap.Height then
    exit;
  BitMap.Visible := False;
  with Bitmap.Canvas do
  begin
    FirstC := 0;
    LastC := BitMap.Width;
    for r := 0 to BitMap.Height div 2 do
    begin
      for c := FirstC to LastC do
      begin
        FixPixels(c, r);
      end;
      Inc(FirstC);
      Dec(LastC);
    end;
  end;
  BitMap.Visible := True;
end;


Source: http://delphiworld.narod.ru
ID: 03843



Поворот на заданный угол[править | править код]

...я думаю над принудительным грубым методом, но его эффективность может быть сомнительна, и не вздумайте пробовать его без сопроцессора!

Сделайте наложение пиксель-на-пиксель из исходного изображение на целевой (используя свойство Canvas.Pixels). Для каждого пикселя осуществите преобразование полярных координат, добавьте компенсирующий угол к полярной координате, затем спозиционируйте это обратно на координаты прямоугольника, и разместите пиксель с новыми координатами на целевом изображении. Также вы можете добавлять какой-либо псевдослучайный пиксель через определенное их количество, если хотите задать какую-то точность вашей операции.

Для преобразования X- и Y-координат объявлены следующие переменные:

  • X, Y - старые координаты пикселя
  • X1, Y1 - новые координаты пикселя
  • T - угол вращения (в радианах)
  • R, A - промежуточные величины, представляющие собой полярные координаты
R = Sqrt(Sqr(X) + Sqr(Y));
A = Arctan(Y/X);
X1 = R * Cos(A+T);
Y1 = R * Sin(A+T);

Я отдаю себе отчет, что это не оптимальное решение, поэтому, если вы найдете еще какое-либо решение, дайте мне знать. В действительности мой метод работает, но делает это очень медленно.

Создайте наложение пиксель-на-пиксель исходного изображение на целевое (используя свойство Canvas.Pixels).

...это хорошее начало, но я думаю другой способ будет немного лучшим. Создайте наложение пиксель-на-пиксель целевого изображения на исходное так, чтобы нам было нужно вычислять откуда брать нужные пиксели, а не думать над тем, куда их нужно поместить.

Для начала вот мой вариант формулы вращения:

  • x, y - координаты в целевом изображении
  • t - угол
  • u, v - координаты в исходном изображении
x = u * cos(t) - v * sin(t)
y = v * cos(t) + u * sin(t)

Теперь, если я захочу решить эти уравнения и вычислить u и v (привести их к правой части уравнения), то формулы будут выглядеть следующим образом (без гарантии, по этой причине я и включил исходные уравнения!):

      x * cos(t) + y
u = --------------------
    sqr(cos(t)) + sin(t)

      y * cos(t) - x
v = --------------------
    sqr(cos(t)) + sin(t)

Так, подразумевая, что вы уже знаете угол вращения, можно вычислить константы cos(t) и 1/sqr(cos(t))+sin(t) непосредственно перед самим циклом; это может выглядеть примерно так (приблизительный код):


ct := cos(t);
ccst := 1/sqr(cos(t))+sin(t);
for x := 0 to width do
begin
  for y := 0 to height do
  begin
    Dest.Pixels[x, y] := Source.Pixels[Round((x * ct + y) * ccst), Round((y * ct - x) * ccst)];
  end;
end;


Если вы хотите ускорить этот процесс, и при этом волнуетесь за накопление ошибки округления, то вам следует обратить внимание на используемую нами технологию: мы перемещаем за один раз один пиксель, дистанция между пикселями равна u, v содержит константу, определяющую колонку с перемещаемым пикселем. Я использую рассчитанные выше переменные как рычаг с коротким плечом (с вычисленной длиной и точкой приложения). Просто поместите в (x,y) = (1,0) и (x,y) = (0,1) и уравнение, приведенное выше:


duCol := ct * ccst;
dvCol := -ccst;

duRow := ccst;
dvRow := ct * ccst;

uStart := 0;
vStart := 0;

for x := 0 to width do
begin
  u := uStart;
  v := vStart;
  for y := 0 to height do
  begin
    Dest.Pixels[x, y] := Source.Pixels[Round(u), Round(v)];
    u := u + rowdu;
    v := v + rowdv;
  end;
  uStart := uStart + duCol;
  vStart := vStart + dvCol;
end;


Приведенный выше код можно использовать "как есть", и я не даю никаких гарантий относительно его использования!

Если вы в душе испытатель, и хотите попробовать вращение вокруг произвольной точки, попробуйте поиграться со значениями u и v:

Xp, Yp (X-sub-p, Y-sub-p) точка оси вращения, другие константы определены выше
x = Xp + (u - Xp) * cos(t) - (y - Yp) * sin(t)
y = Yp + (y - Yp) * cos(t) - (x - Xp) * sin(t)

Оригинальные уравнения:

 x = u * cos(t) - v * sin(t)
 y = v * cos(t) + u * sin(t)

верны, но когда я решаю их для u и v, я получаю это:

     x * cos(t) + y * sin(t)
 u = -----------------------
    sqr(cos(t)) + sqr(sin(t))


     y * cos(t) - x * sin(t)
 v = ------------------------
     sqr(cos(t)) + sqr(sin(t))


Source: http://delphiworld.narod.ru
ID: 03844



Вращение изображения на заданный угол[править | править код]

{**** UBPFD *********** by delphibase.endimus.ru ****
>> Вращение изображения на заданный угол

Зависимости: Windows, Classes, Graphics
Автор:       Fenik, chook_nu@uraltc.ru, Новоуральск
Copyright:   Автор Федоровских Николай
Дата:        2 июня 2002 г.
**************************************************** }

procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);
type
  TRGB = record
    B, G, R: Byte;
  end;
  pRGB = ^TRGB;
  pByteArray = ^TByteArray;
  TByteArray = array[0..32767] of Byte;
  TRectList = array [1..4] of TPoint;

var
  x, y, W, H, v1, v2: Integer;
  Dest, Src: pRGB;
  VertArray: array of pByteArray;
  Bmp: TBitmap;

  procedure SinCos(AngleRad: Double; var ASin, ACos: Double);
  begin
    ASin := Sin(AngleRad);
    ACos := Cos(AngleRad);
  end;

  function RotateRect(const Rect: TRect; const Center: TPoint; Angle: Double): TRectList;
  var
    DX, DY: Integer;
    SinAng, CosAng: Double;

    function RotPoint(PX, PY: Integer): TPoint;
    begin
      DX := PX - Center.x;
      DY := PY - Center.y;
      Result.x := Center.x + Round(DX * CosAng - DY * SinAng);
      Result.y := Center.y + Round(DX * SinAng + DY * CosAng);
    end;

  begin
    SinCos(Angle * (Pi / 180), SinAng, CosAng);
    Result[1] := RotPoint(Rect.Left, Rect.Top);
    Result[2] := RotPoint(Rect.Right, Rect.Top);
    Result[3] := RotPoint(Rect.Right, Rect.Bottom);
    Result[4] := RotPoint(Rect.Left, Rect.Bottom);
  end;

  function Min(A, B: Integer): Integer;
  begin
    if A < B then
      Result := A
    else
      Result := B;
  end;

  function Max(A, B: Integer): Integer;
  begin
    if A > B then
      Result := A
    else
      Result := B;
  end;

  function GetRLLimit(const RL: TRectList): TRect;
  begin
    Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x));
    Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y));
    Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x));
    Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y));
  end;

  procedure Rotate;
  var
    x, y, xr, yr, yp: Integer;
    ACos, ASin: Double;
    Lim: TRect;
  begin
    W := Bmp.Width;
    H := Bmp.Height;
    SinCos(-Angle * Pi/180, ASin, ACos);
    Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), Angle));
    Bitmap.Width := Lim.Right - Lim.Left;
    Bitmap.Height := Lim.Bottom - Lim.Top;
    Bitmap.Canvas.Brush.Color := BackColor;
    Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
    for y := 0 to Bitmap.Height - 1 do
    begin
      Dest := Bitmap.ScanLine[y];
      yp := y + Lim.Top;
      for x := 0 to Bitmap.Width - 1 do
      begin
        xr := Round(((x + Lim.Left) * ACos) - (yp * ASin));
        yr := Round(((x + Lim.Left) * ASin) + (yp * ACos));
        if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then
        begin
          Src := Bmp.ScanLine[yr];
          Inc(Src, xr);
          Dest^ := Src^;
        end;
        Inc(Dest);
      end;
    end;
  end;

begin
  Bitmap.PixelFormat := pf24Bit;
  Bmp := TBitmap.Create;
  try
    Bmp.Assign(Bitmap);
    W := Bitmap.Width - 1;
    H := Bitmap.Height - 1;
    if Frac(Angle) <> 0.0 then
      Rotate
    else
    case Trunc(Angle) of
      -360, 0, 360, 720: Exit;

      90, 270:
      begin
        Bitmap.Width := H + 1;
        Bitmap.Height := W + 1;
        SetLength(VertArray, H + 1);
        v1 := 0;
        v2 := 0;
        if Angle = 90.0 then
          v1 := H
        else
          v2 := W;
        for y := 0 to H do
          VertArray[y] := Bmp.ScanLine[Abs(v1 - y)];
        for x := 0 to W do
        begin
          Dest := Bitmap.ScanLine[x];
          for y := 0 to H do
          begin
            v1 := Abs(v2 - x)*3;
            with Dest^ do
            begin
              B := VertArray[y, v1];
              G := VertArray[y, v1+1];
              R := VertArray[y, v1+2];
            end;
            Inc(Dest);
          end;
        end
      end;

      180:
      begin
        for y := 0 to H do begin
          Dest := Bitmap.ScanLine[y];
          Src := Bmp.ScanLine[H - y];
          Inc(Src, W);
          for x := 0 to W do
          begin
            Dest^ := Src^;
            Dec(Src);
            Inc(Dest);
          end;
        end;
      end;
    else
      Rotate;
    end;
  finally
    Bmp.Free;
  end;
end;


Пример использования:

RotateBitmap(FBitmap, 17.23, clWhite);


Author: Fenik
Source: Взято из http://forum.sources.ru
ID: 03845



Поворот на заданный угол с записью в новый Bitmap[править | править код]

const
  PixelMax = 32768;

type
  pPixelArray = ^TPixelArray;
  TPixelArray = array [0..PixelMax-1] of TRGBTriple;

procedure RotateBitmap_ads(SourceBitmap: TBitmap;
  out DestBitmap: TBitmap; Center: TPoint; Angle: Double);
var
  cosRadians: Double;
  inX: Integer;
  inXOriginal: Integer;
  inXPrime: Integer;
  inXPrimeRotated: Integer;
  inY: Integer;
  inYOriginal: Integer;
  inYPrime: Integer;
  inYPrimeRotated: Integer;
  OriginalRow: pPixelArray;
  Radians: Double;
  RotatedRow: pPixelArray;
  sinRadians: Double;
begin
  DestBitmap.Width := SourceBitmap.Width;
  DestBitmap.Height := SourceBitmap.Height;
  DestBitmap.PixelFormat := pf24bit;
  Radians := -(Angle) * PI / 180;
  sinRadians := Sin(Radians);
  cosRadians := Cos(Radians);
  for inX := DestBitmap.Height-1 downto 0 do
  begin
    RotatedRow := DestBitmap.Scanline[inX];
    inXPrime := 2*(inX - Center.y) + 1;
    for inY := DestBitmap.Width-1 downto 0 do
    begin
      inYPrime := 2*(inY - Center.x) + 1;
      inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians);
      inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians);
      inYOriginal := (inYPrimeRotated - 1) div 2 + Center.x;
      inXOriginal := (inXPrimeRotated - 1) div 2 + Center.y;
      if (inYOriginal >= 0) and (inYOriginal <= SourceBitmap.Width-1)
      and (inXOriginal >= 0) and (inXOriginal <= SourceBitmap.Height-1) then
      begin
        OriginalRow := SourceBitmap.Scanline[inXOriginal];
        RotatedRow[inY] := OriginalRow[inYOriginal]
      end
      else
      begin
        RotatedRow[inY].rgbtBlue := 255;
        RotatedRow[inY].rgbtGreen := 0;
        RotatedRow[inY].rgbtRed := 0
      end;
    end;
  end;
end;

{ Usage: }
procedure TForm1.Button1Click(Sender: TObject);
var
  Center: TPoint;
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    Center.y := (Image.Height div 2) + 20;
    Center.x := (Image.Width div 2) + 0;
    RotateBitmap_ads(Image.Picture.Bitmap, Bitmap, Center, Angle);
    Angle := Angle + 15;
    Image2.Picture.Bitmap.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;


Source: http://delphiworld.narod.ru/
ID: 03846



Вращение многогранников[править | править код]

WEB-сайт: http://rax.ru/click?apg67108864.narod.ru/

Здесь я бы хотел рассказать не о том, как работать с DelphiX, OpenGL или Direct, а о том, как можно вращать многогранники с помощью простых действий: moveto и lineto.

Здесь рассмотрим пример вращения куба. Будем рисовать на Canvase (например Listbox). Сначала нарисуем вращающийся квадрат (точнее 2 квадрата и соединим их). Пусть q - угол поворота квадрата, который мы рисуем. Очевидно, что нам надо задать координаты вершин квадрата - a: array [1..5, 1..2] of Integer. 1..4+1 - количество вершин квадрата (почему +1 будет объяснено позже). 1..2 - координата по X и Y. Кто учился в школе, наверное помнит, что уравнение окружности: X^2 + Y^2 = R^2, кто хорошо учился в школе, возможно вспомнит уравнение эллипса: (X^2) / (a^2) + (Y^2) / (b^2) = 1. Но это нам не надо. Нам понадобится уравнение эллипса в полярных координатах:

x = a * sin(t);
y = a * cos(t);
t = 0..2 * PI;

(учащиеся университетов и институтов ликуют).


С помощью данного уравнения мы заполняем массив с координатами.

for i := 1 to 5 do
begin
  // координата по Х; q + i * pi / 2 - угол поворота
  // i-той вершины квадрата.
  a[i, 1] := Trunc(80 * sin(q + i * pi / 2));
  // координата по Y; знак минус - потому что координаты
  // считаются с верхнего левого угла
  a[i, 1] := Trunc(-30 * cos(q + i * pi / 2));
end;


Сейчас будем рисовать квадрат:

for i := 1 to 4 do
begin
  MoveTo(100 + a[i, 1], 50 + a[i, 2]); // Встаем на i-ую точку квадрата.
  LineTo(100 + a[i+1, 1], 50 + a[i+1, 2]); // Рисуем линию к i+1-ой точке.
  // Вот почему array[1..5, 1..2], иначе - выход за границы.
end;


Затем рисуем второй такой же квадрат, но пониже (или повыше). Соединяем линиями первый со вторым:

for i := 1 to 4 do
begin
  MoveTo(100 + a[i, 1], 50 + a[i, 2]);
  LineTo(100 + a[i, 1], 130 + a[i, 2]);
end;


Осталось очистить Listbox, увеличить q и сделать сначала. Все!!!

Можно также скрывать невидимые линии - когда q находится в определенном интервале. Также можно поизвращаться: повернуть куб в другой плоскости - поворот осей(для тех, кто знает формулу).


Author: Айткулов Павел
Source: http://delphiworld.narod.ru/
ID: 03847
ID: 04107


Вращение Bitmap с учетом фонового цвета[править | править код]

// (c) Copyright original C Code: Code Guru
function RotateBitmap(var hDIB: HGlobal; radang: Double; clrBack: TColor): Boolean;
var
  lpDIBBits: Pointer;
  lpbi, hDIBResult: PBitmapInfoHeader;
  bpp, nColors, nWidth, nHeight, nRowBytes: Integer;
  cosine, sine: Double;
  x1, y1, x2, y2, x3, y3, minx, miny, maxx, maxy, ti, x, y, w, h: Integer;
  nResultRowBytes, nHeaderSize: Integer;
  i, len: Longint;
  lpDIBBitsResult: Pointer;
  dwBackColor: DWORD;
  PtrClr: PRGBQuad;
  RbackClr, GBackClr, BBackClr: Word;
  sourcex, sourcey: Integer;
  mask: Byte;
  PtrByte: PByte;
  dwpixel: DWORD;
  PtrDWord: PDWord;
  hDIBResInfo: HGlobal;
begin;
  // Get source bitmap info
  lpbi := PBitmapInfoHeader(GlobalLock(hdIB));
  nHeaderSize := lpbi^.biSize + lpbi^.biClrUsed * SizeOf(TRGBQUAD);
  lpDIBBits := Pointer(Longint(lpbi) + nHeaderSize);
  bpp := lpbi^.biBitCount; // Bits per pixel
  ncolors := lpbi^.biClrUsed; // Already computed when bitmap was loaded
  nWidth := lpbi^.biWidth;
  nHeight := lpbi^.biHeight;
  nRowBytes := ((((nWidth * bpp) + 31) and (not 31)) shr 3);

  // Compute the cosine and sine only once
  cosine := cos(radang);
  sine := sin(radang);

  // Compute dimensions of the resulting bitmap
  // First get the coordinates of the 3 corners other than origin
  x1 := Ceil(-nHeight * sine); // Originally floor at all places
  y1 := Ceil(nHeight * cosine);
  x2 := Ceil(nWidth * cosine - nHeight * sine);
  y2 := Ceil(nHeight * cosine + nWidth * sine);
  x3 := Ceil(nWidth * cosine);
  y3 := Ceil(nWidth * sine);

  minx := Min(0, Min(x1, Min(x2, x3)));
  miny := Min(0, Min(y1, Min(y2, y3)));
  maxx := Max(0, Max(x1, Max(x2, x3))); // added max(0,
  maxy := Max(0, Max(y1, Max(y2, y3))); // added max(0,

  w := maxx - minx;
  h := maxy - miny;

  // Create a DIB to hold the result
  nResultRowBytes := ((((w * bpp) + 31) and (not 31)) div 8);
  len := nResultRowBytes * h;
  hDIBResInfo := GlobalAlloc(GMEM_MOVEABLE, len + nHeaderSize);
  if hDIBResInfo = 0 then
  begin
    Result := False;
    Exit;
  end;

  hDIBResult := PBitmapInfoHeader(GlobalLock(hDIBResInfo));
  // Initialize the header information
  CopyMemory(hDIBResult, lpbi, nHeaderSize);
  //BITMAPINFO &bmInfoResult = *(LPBITMAPINFO)hDIBResult ;
  hDIBResult^.biWidth := w;
  hDIBResult^.biHeight := h;
  hDIBResult^.biSizeImage := len;
  lpDIBBitsResult := Pointer(Longint(hDIBResult) + nHeaderSize);

  // Get the back color value (index)
  ZeroMemory(lpDIBBitsResult, len);
  case bpp of
    1:
    begin //Monochrome
      if (clrBack = RGB(255, 255, 255)) then
        FillMemory(lpDIBBitsResult, len, $ff);
    end;

    4, 8:
    begin // Search the color table
      PtrClr := PRGBQuad(Longint(lpbi) + lpbi^.bisize);
      RBackClr := GetRValue(clrBack);
      GBackClr := GetGValue(clrBack);
      BBackClr := GetBValue(clrBack);
      for i := 0 to nColors - 1 do // Color table starts with index 0
      begin
        if (PtrClr^.rgbBlue = BBackClr) and
           (PtrClr^.rgbGreen = GBackClr) and
           (PtrClr^.rgbRed = RBackClr) then
        begin
          if (bpp = 4) then // if(bpp==4) i = i | i<<4;
            ti := i or (i shl 4)
          else
            ti := i;
          FillMemory(lpDIBBitsResult, ti, len);
          break;
        end;
        Inc(PtrClr);
      end; // If not match found the color remains black
    end;
    
    16:
    begin
      (* When the Compression field is set to BI_BITFIELDS,
         Windows 95 supports
         only the following 16bpp color masks: A 5-5-5 16-bit image, where the blue mask
         is $001F, the green mask is $03E0, and the red mask is $7C00; and a 5-6-5
         16-bit image, where the blue mask is $001F, the green mask is $07E0,
         and the red mask is $F800. *)
      PtrClr := PRGBQuad(Longint(lpbi) + lpbi^.bisize);
      if (PtrClr^.rgbRed = $7c00) then // Check the Red mask
      begin // Bitmap is RGB555
        dwBackColor := ((GetRValue(clrBack) shr 3) shl 10)
                     + ((GetRValue(clrBack) shr 3) shl 5)
                     + (GetBValue(clrBack) shr 3);
      end
      else
      begin // Bitmap is RGB565
        dwBackColor := ((GetRValue(clrBack) shr 3) shl 11)
                     + ((GetRValue(clrBack) shr 2) shl 5)
                     + (GetBValue(clrBack) shr 3);
      end;
    end;

    24, 32:
    begin
      dwBackColor := ((GetRValue(clrBack)) shl 16)
                  or ((GetGValue(clrBack)) shl 8)
                  or ((GetBValue(clrBack)));
    end;
  end;

  // Now do the actual rotating - a pixel at a time
  // Computing the destination point for each source point
  // will leave a few pixels that do not get covered
  // So we use a reverse transform - e.i. compute the source point
  // for each destination point
  for y := 0 to h - 1 do
   begin
     for x := 0 to w - 1 do
     begin
       sourcex := Floor((x + minx) * cosine + (y + miny) * sine);
       sourcey := Floor((y + miny) * cosine - (x + minx) * sine);
       if ((sourcex >= 0) and (sourcex < nWidth)
       and (sourcey >= 0) and (sourcey < nHeight)) then
       begin // Set the destination pixel
         case bpp of
           1:
           begin // Monochrome
             mask := PByte(Longint(lpDIBBits) + (nRowBytes * sourcey)
                   + (sourcex div 8))^ and ($80 shr (sourcex mod 8));
             if mask <> 0 then
               mask := $80 shr (x mod 8);
             PtrByte  := PByte(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x div 8));
             PtrByte^ := PtrByte^ and (not ($80 shr (x mod 8)));
             PtrByte^ := PtrByte^ or mask;
           end;

           4:
           begin
             if ((sourcex and 1) <> 0) then
               mask := $0f
             else
               mask := $f0;
             mask := PByte(Longint(lpDIBBits) + (nRowBytes * sourcey) + (sourcex div 2))^ and mask;
             if ((sourcex and 1) <> (x and 1)) then
             begin
               if (mask and $f0) <> 0 then
                 mask := (mask shr 4)
               else
                 mask := (mask shl 4);
             end;
             PtrByte := PByte(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x div 2));
             if ((x and 1) <> 0) then
               PtrByte^ := PtrByte^ and (not $0f)
             else
               PtrByte^ := PtrByte^ and (not $f0);
             PtrByte^ := PtrByte^ or Mask;
           end;

           8:
           begin
             mask := PByte(Longint(lpDIBBits) + (nRowBytes * sourcey) + sourcex)^;
             PtrByte  := PByte(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + x);
             PtrByte^ := mask;
           end;

           16:
           begin
             dwPixel := PDWord(Longint(lpDIBBits) + (nRowBytes * sourcey) + (sourcex * 2))^;
             PtrDword  := PDWord(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x * 2));
             PtrDword^ := Word(dwpixel);
           end;

           24:
           begin
             dwPixel := PDWord(Longint(lpDIBBits) + (nRowBytes * sourcey) + (sourcex * 3))^ and $ffffff;
             PtrDword  := PDWord(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x * 3));
             PtrDword^ := PtrDword^ or dwPixel;
           end;

           32:
           begin
             dwPixel := PDWord(Longint(lpDIBBits) + (nRowBytes * sourcey) + (sourcex * 4))^;
             PtrDword := PDWord(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x * 4));
             PtrDword^ := dwpixel;
           end;
         end; // Case
       end
       else
       begin
         // Draw the background color. The background color
         // has already been drawn for 8 bits per pixel and less
         case bpp of
           16:
           begin
             PtrDWord := PDWord(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x * 2));
             PtrDword^ := Word(dwBackColor);
           end;
           24:
           begin
             PtrDWord := PDWord(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x * 3));
             PtrDword^ := PtrDword^ or dwBackColor;
           end;
           32:
           begin
             PtrDWord := PDWord(Longint(lpDIBBitsResult) + (nResultRowBytes * y) + (x * 4));
             PtrDword^ := dwBackColor;
           end;
         end;
       end;
     end;
   end;
   GlobalUnLock(hDIBResInfo);
   GlobalUnLock(hDIB);
   GlobalFree(hDIB);
   hDIB := hDIBResInfo;
   Result := True;
 end;


Source: http://www.swissdelphicenter.ch
ID: 03848