Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

function RotateBitmap(var hDIB: HGlobal; radang: Double; clrBack: TColor): Boolean;
 // (c) Copyright original C Code: Code Guru 
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;