RotatePicture - Rotate a 256-color bitmap by any angle (super-optimized version)

' 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

' this improved version scans only a portion of the image, and builds
' remaining points using simmetry. This algorithm is particularly efficient 
' when the
' center of the rotation is inside the bitmap, the best performances are 
' achieved
' when it is near to the center of the bitmap. Moreover, this code saves some
' CPU time by using pre-calculated values for SIN, COS, and SQR functions.

' 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
'        RotatePicture2 Picture1, Picture2, 50, 50, a
'    Next

Private Sub RotatePicture2(sourcePB As PictureBox, destPB As PictureBox, _
    xc As Long, yc As Long, degrees As Single)

    ' all angles are expressed in 1/10000ths of radians
    Const PI As Long = 31416
    Const HALFPI As Long = 15707
    Const DOUBLEPI As Long = 62831
    
    Const SQRTABLE_MAX As Long = 40000
    
    Static sinTable() As Single
    Static atnTable() As Long
    Static sqrTable() As Single
    Static initialized As Boolean
    
    ' these are used to address the pixel using matrices
    Dim pict1() As Byte
    Dim pict2() As Byte
    Dim p1 As SafeArray2, p2 As SafeArray2
    Dim bmp1 As BITMAP, bmp2 As BITMAP
    ' these are used by the rotating algorithm
    Dim radians As Long
    Dim angle As Long
    Dim angle0 As Long
    Dim distance As Single
    Dim distanceSquared As Long
    Dim deltaX As Long, deltaY As Long
    Dim deltaXSquared As Single, deltaX10000 As Long
    Dim x As Long, y As Long
    Dim dx As Long, dy As Long
    Dim x0 As Long, y0 As Long
    Dim xx As Long, yy As Long
    Dim xStart As Long, xEnd As Long
    Dim yStart As Long, yEnd As Long
    Dim bmWidth1 As Long
    Dim bmHeight1 As Long
    
    ' Initialize sin,cos,sqr tables
    If Not initialized Then
        initialized = True
        
        Dim i As Long
        ' evaluate a table of sin for 360+90 degrees
        ' with a precision of 1/10000 of a radian
        ' this permits to reuse the same table for cosine, too
        ' since COX(x) = SIN(x + 90°)
        ReDim sinTable(0 To 62831 + 15709) As Single
        For i = 0 To UBound(sinTable)
            sinTable(i) = Sin(i / 10000)
        Next
        
        ' evaluate a table for Atn(x)*10000 for x=[0,1], with steps of 0,0001
        ReDim atnTable(0 To 10000) As Long
        For i = LBound(atnTable) To UBound(atnTable)
            atnTable(i) = Atn(i / 10000) * 10000#
        Next
        
        ' evaluate a table for Sqr(i)
        ReDim sqrTable(SQRTABLE_MAX) As Single
        For i = 0 To SQRTABLE_MAX
            sqrTable(i) = Sqr(i)
        Next
    End If
    
    ' 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 1/10000ths of radians
    ' subtracting 628310000 ensure that when radians is used in the
    ' subtraction in the loop, it produces a positive number
    radians = degrees / (180 / 3.14159) * 10000& - 628310000
    
    ' we have several cases, depending on where XC falls
    ' compared to the center of the image
    If xc < bmp2.bmWidth \ 2 Then
        xStart = xc
        xEnd = bmp2.bmWidth - 1
    Else
        xStart = 0
        xEnd = xc
    End If

    If yc < bmp2.bmHeight \ 2 Then
        yStart = yc
        yEnd = bmp2.bmWidth - 1
    Else
        yStart = 0
        yEnd = yc
    End If
    
    ' the main loop of this routine scans a squared portion
    ' of the image whose corners falls on the rotation center
    ' Of the four squares that touch the rotation center, here
    ' we choose the one with the highest number of pixels
    ' withing the image
    
    If xEnd - xStart > yEnd - yStart Then
        If yStart = 0 Then
            yStart = yEnd - (xEnd - xStart)
        Else
            yEnd = yStart + (xEnd - xStart)
        End If
    Else
        If xStart = 0 Then
            xStart = xEnd - (yEnd - yStart)
        Else
            xEnd = xStart + (yEnd - yStart)
        End If
    End If

    bmWidth1 = bmp1.bmWidth
    bmHeight1 = bmp1.bmHeight
    
    ' rotate the picture
    
    For x = xStart To xEnd
        ' these values are loop invariant for the following For-Next
        deltaX = x - xc
        deltaXSquared = deltaX * deltaX
        deltaX10000 = deltaX * 10000

        For y = yStart To yEnd
            deltaY = y - yc
            
            ' evaluate the arc-tangent of (deltaY/deltaX)
            ' many IFs are required, since the atnTable() array only
            ' covers the range [0,1] - if (deltaY/deltaX) is > 1 we
            ' must use its reciprocal deltaX/deltaY
            If deltaX > 0 Then
                If deltaY >= 0 Then
                    If deltaY < deltaX Then
                        angle = atnTable((deltaY * 10000) \ deltaX)
                    Else
                        angle = HALFPI - atnTable(deltaX10000 \ deltaY)
                    End If
                Else
                    If -deltaY < deltaX Then
                        angle = -atnTable((deltaY * -10000) \ deltaX)
                    Else
                        angle = -HALFPI + atnTable(-deltaX10000 \ deltaY)
                    End If
                End If
            ElseIf deltaX < 0 Then
                If deltaY > 0 Then
                    If deltaY < -deltaX Then
                        angle = PI - atnTable((deltaY * -10000) \ deltaX)
                    Else
                        angle = HALFPI + atnTable(-deltaX10000 \ deltaY)
                    End If
                Else
                    If deltaY > deltaX Then
                        angle = PI + atnTable((deltaY * 10000) \ deltaX)
                    Else
                        angle = -HALFPI - atnTable(deltaX10000 \ deltaY)
                    End If
                End If
            Else
                If deltaY >= 0 Then
                    angle = HALFPI
                Else
                    angle = -HALFPI
                End If
            End If
            ' --- end of arc-tangent evaluation
                
            ' "angle" is the angle of the segment that goes from
            ' the center to (x,y) - since we wish to evaluate the
            ' color of this point, we must check the point in the
            ' original bitmap that has the same distance from the
            ' center but with a different angle
                
            ' evaluate the distance of (x,y) from the rotation
            ' center, using if possible the value already stored
            ' in sqrTable()
            distanceSquared = deltaXSquared + deltaY * deltaY
            If distanceSquared <= SQRTABLE_MAX Then
                distance = sqrTable(distanceSquared)
            Else
                distance = Sqr(distanceSquared)
            End If
            
            ' the old point in the original bitmap has same
            ' distance but a different angle
            angle0 = (angle - radians) Mod DOUBLEPI
            
            ' evaluate the x,y offset of the old point from
            ' the rotation center
            dx = distance * sinTable(angle0 + HALFPI)  ' really cosine
            dy = distance * sinTable(angle0)
            
            ' if (x,y) falls within the image
            If x >= 0 And x < bmWidth1 And y >= 0 And y < bmHeight1 Then
                ' (x0,y0) is the corresponding point in the original bitmap
                x0 = xc + dx
                y0 = yc + dy
                ' if (x0,y0) falls within the bitmap boundaries, copy the pixel
                ' else, set the (x,y) pixel to zero (background color)
                If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 Then
                    pict2(x, y) = pict1(x0, y0)
                Else
                    pict2(x, y) = 0
                End If
            
                ' this is the point simmetrical to the rotation center - this
                ' block is within the outer If clause because the simmetrical
                ' point can be within the bitmap only if (x,y) was within the
                ' bitmap too
                xx = xc - deltaX
                yy = yc - deltaY
                If xx >= 0 And xx < bmWidth1 And yy >= 0 And yy < bmHeight1 Then
                    x0 = xc - dx
                    y0 = yc - dy
                    If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 _
                        Then
                        pict2(xx, yy) = pict1(x0, y0)
                    Else
                        pict2(xx, yy) = 0
                    End If
                End If
            
            End If
            
            ' now deal with the pixel 90° ahead of the one in (x,y)
            xx = xc + deltaY
            yy = yc - deltaX
            If xx >= 0 And xx < bmWidth1 And yy >= 0 And yy < bmHeight1 Then
                x0 = xc + dy
                y0 = yc - dx
                If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 Then
                    pict2(xx, yy) = pict1(x0, y0)
                Else
                    pict2(xx, yy) = 0
                End If
            End If

            ' now deal with the pixel 270° ahead of the one in (x,y)
            xx = xc - deltaY
            yy = yc + deltaX
            If xx >= 0 And xx < bmWidth1 And yy >= 0 And yy < bmHeight1 Then
                x0 = xc - dy
                y0 = yc + dx
                If x0 >= 0 And x0 < bmWidth1 And y0 >= 0 And y0 < bmHeight1 Then
                    pict2(xx, yy) = pict1(x0, y0)
                Else
                    pict2(xx, yy) = 0
                End If
            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