RotateBitmap – Rotate a 256-color bitmap by any angle

Option Explicit' This structure holds Bitmap informationPrivate Type BITMAP    bmType As Long    bmWidth As Long    bmHeight As Long    bmWidthBytes As Long    bmPlanes As Integer    bmBitsPixel As Integer    bmBits As LongEnd Type' This structure holds SAFEARRAY infoPrivate 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 LongEnd Type' API declaresPrivate 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:winntgone fishing.bmp")'    Picture2.Picture = LoadPicture("d:winntgone fishing.bmp")'    ' Rotate by 360°   '    Dim a As Single'    For a = 0 To 360 Step 5'        RotatePicture Picture1, Picture2, 50, 50, a'    NextSub 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.RefreshEnd Sub' Support routinePrivate Function VarPtrArray(arr As Variant) As Long    CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, 4End Function

Share the Post:
Share on facebook
Share on twitter
Share on linkedin


The Latest

your company's audio

4 Areas of Your Company Where Your Audio Really Matters

Your company probably relies on audio more than you realize. Whether you’re creating a spoken text message to a colleague or giving a speech, you want your audio to shine. Otherwise, you could cause avoidable friction points and potentially hurt your brand reputation. For example, let’s say you create a

chrome os developer mode

How to Turn on Chrome OS Developer Mode

Google’s Chrome OS is a popular operating system that is widely used on Chromebooks and other devices. While it is designed to be simple and user-friendly, there are times when users may want to access additional features and functionality. One way to do this is by turning on Chrome OS

homes in the real estate industry

Exploring the Latest Tech Trends Impacting the Real Estate Industry

The real estate industry is changing thanks to the newest technological advancements. These new developments — from blockchain and AI to virtual reality and 3D printing — are poised to change how we buy and sell homes. Real estate brokers, buyers, sellers, wholesale real estate professionals, fix and flippers, and beyond may