Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB5,VB6
Expertise: Advanced
Oct 20, 2001

RotateBitmap - Rotate a 256-color bitmap by any angle

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
Francesco Balena
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap