Rotate and Resize a Picture on any Windows OS

Option Explicit
 
Private Const LR_COPYRETURNORG = &H4
Private Const RGN_XOR = &H3
 
Private Type Bitmap
    Type As Long
    Width As Long
    Height As Long
    WidthBytes As Long
    Planes As Integer
    BitsPixel As Integer
    Bits As Long
End Type
 
Private Type BITMAPINFOHEADER
    Size As Long
    Width As Long
    Height As Long
    Planes As Integer
    BitCount As Integer
    Compression As Long
    SizeImage As Long
    XPelsPerMeter As Long
    YPelsPerMeter As Long
    ClrUsed As Long
    ClrImportant As Long
End Type
 
Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
 
Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
 
Private Type PicBmpBase
    Size As Long
    Type As Long
    hBMP As Long
    hPal As Long
    hReserved As Long
End Type
 
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Long, ByVal handle As Long, ByVal dw 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 SetDIBitsToDevice Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal imageType As Long, ByVal NewWidth As Long, ByVal NewHeight As Long, ByVal lFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmpBase, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 
Private mBits() As Byte ' DIB bits buffer
Private mHeight As Long ' Height
Private mWidth As Long ' Width
Private mScanX As Integer ' Extra bytes per scan line
Private mRgn As Long ' Region pointer
 
Public Property Let Picture(vData As Picture)
    Dim vBMP As Bitmap ' Basic image info
    Dim lBmp As Long ' Copy of image
    Dim lDC As Long ' Temporary device context
    Dim vBMI As BITMAPINFO ' Basic DIB info
      On Error GoTo ErrorRtn
 
    ' Reset
    Erase mBits
    mWidth = 0
    mHeight = 0
    Me.DeleteRegion
    
    Call GetObject(vData.handle, Len(vBMP), vBMP) ' Get bitmap info
    If (vBMP.Width > 0) And (vBMP.Height > 0) Then
        lBmp = CopyImage(vData.handle, 0, 0, 0, LR_COPYRETURNORG) ' Create temp copy
        lDC = CreateCompatibleDC(0) ' Create temp device context
        Call SelectObject(lDC, lBmp) ' Select image into temp dc
        vBMI.bmiHeader.Size = Len(vBMI.bmiHeader) ' Set up for image
        Call GetDIBits(lDC, lBmp, 0, vBMP.Height, ByVal 0&, vBMI, 0) ' Get DIB info
 
        If vBMI.bmiHeader.Width = vBMP.Width And vBMI.bmiHeader.BitCount >= 24 Then ' Check for validity
            ReDim mBits(vBMI.bmiHeader.SizeImage - 1) ' Allocate buffer
            Call GetDIBits(lDC, lBmp, 0, vBMI.bmiHeader.Height, mBits(0), vBMI, 0) ' Get bits
            mWidth = vBMI.bmiHeader.Width ' Store width
            mHeight = vBMI.bmiHeader.Height ' Store height
            mScanX = ((vBMI.bmiHeader.SizeImage - (mWidth * mHeight * 3)) / mHeight) Mod mWidth ' Count extra bytes
        Else
           MsgBox "Invalid Bitcount"
        End If
        Call DeleteObject(lBmp) ' Delete temp image
        Call DeleteDC(lDC) ' Delete temp dc
    End If
    
    GoTo ExitRtn
 
ErrorRtn:
    DisplayError "clsBitmap.Let Picture", Err.Number, Err.Description
 
ExitRtn:
 
 
End Property
 
Public Property Get Picture() As Picture
    Dim lDC As Long ' Temporary device context
    Dim vBMI As BITMAPINFO ' Basic DIB info
    Dim lBmp As Long ' Copy of image
    Dim vIDispatch As GUID ' IIDispatch GUID
    Dim vPic As PicBmpBase ' OLE picture info
    Dim lReturn As Long
    
    On Error GoTo ErrorRtn
    
    
    If StrPtr(mBits) <> 0 Then ' Check for bits
        lDC = CreateCompatibleDC(0) ' Create temp dc
        
        With vBMI.bmiHeader ' Set up for image
            .BitCount = 24
            .Planes = 1
            .Width = mWidth
            .Height = mHeight
            .SizeImage = UBound(mBits) + 1
            .Size = Len(vBMI.bmiHeader)
        End With
        lBmp = CreateDIBSection(lDC, vBMI, 0, 0, 0, 0) ' Create a temp blank image
        
        Call SelectObject(lDC, lBmp) ' Select image into temp DC
                
        Call SetDIBitsToDevice(lDC, 0, 0, mWidth, mHeight, 0, 0, 0, mHeight, mBits(0), vBMI, 0) ' Set bits
                
        With vIDispatch ' Setup for IIDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        
        
        With vPic ' Setup for new picture
            .Size = Len(vPic)
            .Type = vbPicTypeBitmap
            .hBMP = lBmp
            .hPal = 0&
        End With
        
        Call OleCreatePictureIndirect(vPic, vIDispatch, 1, Picture) ' Convert image to OLE picture
    
        Call DeleteDC(lDC) ' Delete temp dc
    Else
        MsgBox "NoBits"
    End If
    
    
    GoTo ExitRtn
 
ErrorRtn:
    DisplayError "clsBitmap.Get Picture", Err.Number, Err.Description
 
ExitRtn:
 
 
End Property
 
Public Property Let Bits(vData() As Byte)
    mBits = vData
End Property
Public Property Get Bits() As Byte()
    Bits = mBits
End Property
 
Public Property Get Width() As Long
    Width = mWidth
End Property
 
Public Property Get Height() As Long
    Height = mHeight
End Property
 
Public Sub DeleteRegion()
    If mRgn <> 0 Then ' Check for region
        Call DeleteObject(mRgn) ' Delete region
        mRgn = 0 ' Clear pointer
    End If
End Sub
 
Private Sub DisplayError(sProcName As String, Optional vErrNo, Optional vErrDesc)
Dim sErrors As String
Dim lMouse As Long
    On Error Resume Next
 
    lMouse = Screen.MousePointer
    Screen.MousePointer = Default
    sErrors = sProcName
    sErrors = sErrors & vbCrLf & vErrNo & "-" & vErrDesc
    MsgBox sErrors, vbCritical, sProcName
    Screen.MousePointer = lMouse
    
End Sub
 
Private Sub Class_Terminate()
    Erase mBits ' Empty buffer
    Me.DeleteRegion ' Delete region, if any
End Sub
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218: