Binaryworld - RotateBitmap - Rotate a 256-color bitmap by any angle ... [ VB -> Graphics ]

Option Explicit

' This structure holds Bitmap information
Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

' This structure holds SAFEARRAY info
Private Type SafeArray2
  cDims As Integer
  fFeatures As Integer
  cbElements As Long
  cLocks As Long
  pvData As Long
  cElements1 As Long
  lLbound1 As Long
  cElements2 As Long
  lLbound2 As Long
End Type

' API declares
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As _
  Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal _
  hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

' Rotate a 256-color bitmap by any angle:
' sourcePB is the source PictureBox control (may be hidden)
' destPB is the destination PictureBox control
' XC, YC are the coordinates of the rotation center
' ANGLE is the rotation angle in degrees
'
' IMPORTANT: the source and destination PictureBox control must initially
' contain the *same* bitmap, to ensure that size and color palette
' are correctly initialized.

' Example:
'  'Load the same image in both source (hidden) and destination controls
'  Picture1.Picture = LoadPicture("d:\winnt\gone fishing.bmp")
'  Picture2.Picture = LoadPicture("d:\winnt\gone fishing.bmp")
'  ' Rotate by 360°
'  Dim a As Single
'  For a = 0 To 360 Step 5
'    RotatePicture Picture1, Picture2, 50, 50, a
'  Next

Sub RotatePicture(sourcePB As PictureBox, destPB As PictureBox, xc As Long, _
  yc As Long, degrees As Single)
  Const PI As Single = 3.141592653
  Dim pict1() As Byte
  Dim pict2() As Byte
  Dim p1 As SafeArray2, p2 As SafeArray2
  Dim bmp1 As BITMAP, bmp2 As BITMAP

  Dim radians As Single
  Dim angle As Single, angle0 As Single
  Dim distance As Single
  Dim deltaX As Long, deltaY As Long
  Dim x As Long, y As Long
  Dim x0 As Long, y0 As Long

  ' get bitmap info
  GetObjectAPI sourcePB.Picture, Len(bmp1), bmp1
  GetObjectAPI destPB.Picture, Len(bmp2), bmp2

  If bmp1.bmPlanes <> 1 Or bmp1.bmBitsPixel <> 8 Or bmp2.bmPlanes <> 1 Or _
    bmp2.bmBitsPixel <> 8 Then
    MsgBox "This routine supports 256-color bitmaps only", vbCritical
    Exit Sub
  End If

  ' have the local matrices point to bitmap pixels
  With p1
    .cbElements = 1
    .cDims = 2
    .lLbound1 = 0
    .cElements1 = bmp1.bmHeight
    .lLbound2 = 0
    .cElements2 = bmp1.bmWidthBytes
    .pvData = bmp1.bmBits
  End With
  CopyMemory ByVal VarPtrArray(pict1), VarPtr(p1), 4

  With p2
    .cbElements = 1
    .cDims = 2
    .lLbound1 = 0
    .cElements1 = bmp2.bmHeight
    .lLbound2 = 0
    .cElements2 = bmp2.bmWidthBytes
    .pvData = bmp2.bmBits
  End With
  CopyMemory ByVal VarPtrArray(pict2), VarPtr(p2), 4

  ' convert the angle into radians
  radians = degrees / (180 / PI)

  ' rotate the picture

  For x = 0 To bmp1.bmWidth - 1
    For y = 0 To bmp1.bmHeight - 1
      deltaX = x - xc
      deltaY = y - yc
      If deltaX > 0 Then
        angle = Atn(deltaY / deltaX)
      ElseIf deltaX < 0 Then
        angle = PI + Atn(deltaY / deltaX)
      Else
        If deltaY > 0 Then angle = PI / 2 Else angle = PI * 3 / 2
      End If
      angle0 = angle - radians
      distance = Sqr(deltaX * deltaX + deltaY * deltaY)

      x0 = xc + distance * Cos(angle0)
      y0 = yc + distance * Sin(angle0)

      If x0 >= 0 And x0 <= UBound(pict1, 1) And y0 >= 0 And y0 <= UBound _
        (pict1, 2) Then
        pict2(x, y) = pict1(x0, y0)
      Else
        pict2(x, y) = 0
      End If

    Next
  Next

  ' release arrays
  CopyMemory ByVal VarPtrArray(pict1), 0&, 4
  CopyMemory ByVal VarPtrArray(pict2), 0&, 4

  ' show the rotated bitmap
  destPB.Refresh
End Sub

' Support routine

Private Function VarPtrArray(arr As Variant) As Long
  CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, 4
End Function