Create xlBitmap Picture From xlScreen Source

'Module1

'Windows XP® Office 2003® Normal Referance List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL

Option Explicit
Private Type GUID

Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte

End Type
Private DispatchGuid As GUID
Private Type uPicDesc

Size As Long
Type As Long
hPic As Long
hPal As Long

End Type
Private PictureDescription As uPicDesc
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private IPic As IPicture
Private hPtr As Long
Sub Create_xlScreenxlBitmap_Picture()

On Error Resume Next
Cells(1, 1).Interior.Color = RGB(0, 0, 0)
Cells(1, 2).Interior.Color = RGB(153, 51, 0)
Cells(1, 3).Interior.Color = RGB(51, 51, 0)
Cells(1, 4).Interior.Color = RGB(0, 51, 0)
Cells(1, 5).Interior.Color = RGB(0, 51, 102)
Cells(1, 6).Interior.Color = RGB(0, 0, 128)
Cells(1, 7).Interior.Color = RGB(51, 51, 153)
Cells(1, 8).Interior.Color = RGB(51, 51, 51)
Cells(2, 1).Interior.Color = RGB(128, 0, 0)
Cells(2, 2).Interior.Color = RGB(255, 102, 0)
Cells(2, 3).Interior.Color = RGB(128, 128, 0)
Cells(2, 4).Interior.Color = RGB(0, 128, 0)
Cells(2, 5).Interior.Color = RGB(0, 128, 128)
Cells(2, 6).Interior.Color = RGB(0, 0, 255)
Cells(2, 7).Interior.Color = RGB(102, 102, 153)
Cells(2, 8).Interior.Color = RGB(128, 128, 128)
Cells(3, 1).Interior.Color = RGB(255, 0, 0)
Cells(3, 2).Interior.Color = RGB(255, 153, 0)
Cells(3, 3).Interior.Color = RGB(153, 204, 0)
Cells(3, 4).Interior.Color = RGB(51, 153, 102)
Cells(3, 5).Interior.Color = RGB(51, 204, 204)
Cells(3, 6).Interior.Color = RGB(51, 102, 255)
Cells(3, 7).Interior.Color = RGB(128, 0, 128)
Cells(3, 8).Interior.Color = RGB(150, 150, 150)
Cells(4, 1).Interior.Color = RGB(255, 0, 255)
Cells(4, 2).Interior.Color = RGB(255, 204, 0)
Cells(4, 3).Interior.Color = RGB(255, 255, 0)
Cells(4, 4).Interior.Color = RGB(0, 255, 0)
Cells(4, 5).Interior.Color = RGB(0, 255, 255)
Cells(4, 6).Interior.Color = RGB(0, 204, 255)
Cells(4, 7).Interior.Color = RGB(153, 51, 102)
Cells(4, 8).Interior.Color = RGB(192, 192, 192)
Cells(5, 1).Interior.Color = RGB(255, 153, 204)
Cells(5, 2).Interior.Color = RGB(255, 204, 153)
Cells(5, 3).Interior.Color = RGB(255, 255, 153)
Cells(5, 4).Interior.Color = RGB(204, 255, 204)
Cells(5, 5).Interior.Color = RGB(204, 255, 255)
Cells(5, 6).Interior.Color = RGB(153, 204, 255)
Cells(5, 7).Interior.Color = RGB(204, 153, 255)
Cells(5, 8).Interior.Color = RGB(255, 255, 255)
RangeSaveAsPicture Range("A1:H5"), "c:\xlScreenxlBitmapPicture.bmp"

End Sub
Private Sub RangeSaveAsPicture(SourceRange As Range, FilePathName As String)

SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
OpenClipboard 0
hPtr = GetClipboardData(2)
CloseClipboard
With DispatchGuid

.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB

End With
With PictureDescription

.Size = Len(PictureDescription)
.Type = 1
.hPic = hPtr
.hPal = 0

End With
OleCreatePictureIndirect PictureDescription, DispatchGuid, True, IPic
stdole.SavePicture IPic, FilePathName

End Sub