Option Explicit

Private Declare Function SetRect Lib "user32" (lpRect As RECT, _
      ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, _
      ByVal y2 As Long) As Long

Private Declare Function PtInRect Lib "user32" (lpRect As RECT, _
      ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc _
      As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
      ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, _
      ByVal wUsage As Long) As Long

Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc _
      As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
      ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, _
      ByVal wUsage As Long) As Long

Private Type RECT
  Left   As Long
  Top    As Long
  Right  As Long
  Bottom As Long
End Type

Private Type BITMAPINFOHEADER
  biSize          As Long
  biWidth         As Long
  biHeight        As Long
  biPlanes        As Integer
  biBitCount      As Integer
  biCompression   As Long
  biSizeImage     As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed       As Long
  biClrImportant  As Long
End Type

Private Type BITMAPINFO
  Header As BITMAPINFOHEADER
  Bits() As Byte
End Type

Private biRct As RECT
Private x As Long, y As Long
Private biW As Long, biH As Long
Private cx As Double, cy As Double
Private dx As Double, dy As Double
Private cosa As Double, sina As Double
Private rx As Double, ry As Double
Private irx As Integer, iry As Integer
Private drx As Double, dry As Double
Private xin As Double, yin As Double
Private r1 As Integer, g1 As Integer, b1 As Integer
Private r2 As Integer, g2 As Integer, b2 As Integer
Private r3 As Integer, g3 As Integer, b3 As Integer
Private r4 As Integer, g4 As Integer, b4 As Integer
Private ir1 As Integer, ig1 As Integer, ib1 As Integer
Private ir2 As Integer, ig2 As Integer, ib2 As Integer
Private R As Integer, G As Integer, B As Integer
Private QuellpictureBuffer As BITMAPINFO
Private ZielpictureBuffer As BITMAPINFO

Private Const Deg2Rad As Double = 0.017453292519943

Public Function RotatePicture(ByRef Quellpicture As PictureBox, _
      ByRef Zielpicture As PictureBox, ByVal Winkel As Double, _
      ByVal AntiAliasing As Boolean)

  Dim QuellpictureWidth  As Long
  Dim QuellpictureHeight As Long
  Dim ZielpictureWidth   As Long
  Dim ZielpictureHeight  As Long

  QuellpictureWidth = Quellpicture.Width
  QuellpictureHeight = Quellpicture.Height
  ZielpictureWidth = Zielpicture.Width
  ZielpictureHeight = Zielpicture.Height

  ReDim QuellpictureBuffer.Bits(3, QuellpictureWidth - 1, _
        QuellpictureHeight - 1)

  With QuellpictureBuffer.Header
    .biSize = 40
    .biWidth = QuellpictureWidth
    .biHeight = -QuellpictureHeight
    .biPlanes = 1
    .biBitCount = 32
    .biSizeImage = 3 * QuellpictureWidth * QuellpictureHeight
  End With

  GetDIBits Quellpicture.hdc, Quellpicture.Image.Handle, 0, _
      QuellpictureHeight, QuellpictureBuffer.Bits(0, 0, 0), _
      QuellpictureBuffer, 0&

  ReDim ZielpictureBuffer.Bits(3, ZielpictureWidth - 1, _
        ZielpictureHeight - 1)

  With ZielpictureBuffer.Header
    .biSize = 40
    .biWidth = ZielpictureWidth
    .biHeight = -ZielpictureHeight
    .biPlanes = 1
    .biBitCount = 32
    .biSizeImage = 3 * ZielpictureWidth * ZielpictureHeight
  End With

  cx = QuellpictureWidth / 2
  cy = QuellpictureHeight / 2

  dx = ZielpictureWidth / 2
  dy = ZielpictureHeight / 2

  cosa = Cos(Winkel * Deg2Rad * -1)
  sina = Sin(Winkel * Deg2Rad * -1)

  biW = QuellpictureWidth - 1
  biH = QuellpictureHeight - 1
  SetRect biRct, 0, 0, biW, biH

  Zielpicture.Cls
  For y = 0 To ZielpictureHeight - 1
    yin = y - dy
    For x = 0 To ZielpictureWidth - 1
      xin = x - dx

      rx = xin * cosa - yin * sina + cx
      ry = xin * sina + yin * cosa + cy

      irx = Int(rx)
      iry = Int(ry)

      If (PtInRect(biRct, irx, iry)) Then
        drx = rx - irx
        dry = ry - iry

        If AntiAliasing Then
          r1 = QuellpictureBuffer.Bits(2, irx, iry)
          g1 = QuellpictureBuffer.Bits(1, irx, iry)
          b1 = QuellpictureBuffer.Bits(0, irx, iry)

          r2 = QuellpictureBuffer.Bits(2, irx + 1, iry)
          g2 = QuellpictureBuffer.Bits(1, irx + 1, iry)
          b2 = QuellpictureBuffer.Bits(0, irx + 1, iry)

          r3 = QuellpictureBuffer.Bits(2, irx, iry + 1)
          g3 = QuellpictureBuffer.Bits(1, irx, iry + 1)
          b3 = QuellpictureBuffer.Bits(0, irx, iry + 1)

          r4 = QuellpictureBuffer.Bits(2, irx + 1, iry + 1)
          g4 = QuellpictureBuffer.Bits(1, irx + 1, iry + 1)
          b4 = QuellpictureBuffer.Bits(0, irx + 1, iry + 1)

          ib1 = b1 * (1 - dry) + b3 * dry
          ig1 = g1 * (1 - dry) + g3 * dry
          ir1 = r1 * (1 - dry) + r3 * dry
          ib2 = b2 * (1 - dry) + b4 * dry
          ig2 = g2 * (1 - dry) + g4 * dry
          ir2 = r2 * (1 - dry) + r4 * dry

          B = ib1 * (1 - drx) + ib2 * drx
          G = ig1 * (1 - drx) + ig2 * drx
          R = ir1 * (1 - drx) + ir2 * drx

          If (R < 0) Then R = 0 Else If (R > 255) Then R = 255
          If (G < 0) Then G = 0 Else If (G > 255) Then G = 255
          If (B < 0) Then B = 0 Else If (B > 255) Then B = 255

          ZielpictureBuffer.Bits(2, x, y) = R
          ZielpictureBuffer.Bits(1, x, y) = G
          ZielpictureBuffer.Bits(0, x, y) = B
        Else
          R = QuellpictureBuffer.Bits(2, irx, iry)
          G = QuellpictureBuffer.Bits(1, irx, iry)
          B = QuellpictureBuffer.Bits(0, irx, iry)

          ZielpictureBuffer.Bits(2, x, y) = R
          ZielpictureBuffer.Bits(1, x, y) = G
          ZielpictureBuffer.Bits(0, x, y) = B
        End If
      End If
    Next x
  Next y
  SetDIBits Zielpicture.hdc, Zielpicture.Image.Handle, 0, _
      ZielpictureHeight, ZielpictureBuffer.Bits(0, 0, 0), _
      ZielpictureBuffer, 0&
End Function