Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biRUsed As Long
biRImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
End Type
Private Type MemoryBitmap
hdc As Long
hBM As Long
oldhDC As Long
wid As Long
hgt As Long
bitmap_info As BITMAPINFO
End Type
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
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" _
() 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 GetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) _
As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) _
As Long
Private Declare Function GetObjectAPI Lib "gdi32" _
Alias "GetObjectA" _
(ByVal hObject As Long, _
ByVal nCount As Long, _
lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const BI_RGB = 0&
Public Sub Test()
Dim oWs As Worksheet
Dim sRes As String
Dim sPrompt As String
sPrompt = "Worksheet" & Space(25) & "Has background picture"
sPrompt = sPrompt & vbCr & String(Len("Worksheet"), "-") & _
Space(25) & String(Len("Has background picture"), "-")
For Each oWs In ThisWorkbook.Worksheets
sRes = IIf(SheetHasBackGroungPicture(oWs), "Yes", "No")
sPrompt = sPrompt & vbCr & oWs.Name & _
Space(Len("Worksheet") + 25 - Len(oWs.Name)) & sRes
Next oWs
Debug.Print sPrompt
End Sub
Private Function SheetHasBackGroungPicture(ByVal sh As Worksheet) As Boolean
Dim i As Long
Dim oLastCell As Range
Set oLastCell = sh.Cells(Rows.Count, Columns.Count)
With oLastCell
i = -1
Do
DoEvents
i = i + 1
Loop Until .Offset(-i).FormatConditions.Count = 0 And .Offset(-i).Interior.Pattern = xlPatternNone
If GetDisplayColor(.Offset(-i), 1, 1) = .Offset(-i).Interior.Color Then
SheetHasBackGroungPicture = GetDisplayColor(.Offset(-i), 10, 10) <> .Offset(-i).Interior.Color
Else
SheetHasBackGroungPicture = True
End If
End With
End Function
Private Function GetDisplayColor(Rng As Range, ByVal PixX As Long, ByVal PixY As Long) As Long
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
Rng.Copy
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
With IID_IDispatch
.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 uPicinfo
.Size = Len(uPicinfo)
.Type = PICTYPE_BITMAP
.hPic = hPtr
.hPal = 0
End With
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
GetDisplayColor = GetColor(IPic, PixX, PixY)
Application.CutCopyMode = False
End Function
Private Function GetColor( _
ByVal Picture As StdPicture, ByVal PixX As Long, ByVal PixY As Long) As Long
Dim bm As BITMAP
Dim memory_bitmap As MemoryBitmap
Call GetObjectAPI(Picture.Handle, Len(bm), bm)
memory_bitmap = MakeMemoryBitmap(bm.bmWidth, bm.bmHeight)
DeleteObject (SelectObject(memory_bitmap.hdc, Picture.Handle))
GetColor = GetPixel(memory_bitmap.hdc, PixX, PixY)
End Function
Private Function MakeMemoryBitmap _
(W As Long, H As Long) As MemoryBitmap
Dim result As MemoryBitmap
Dim bytes_per_scanLine As Long
Dim pad_per_scanLine As Long
Dim lBmp As Long
With result.bitmap_info.bmiHeader
.biBitCount = 32
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(result.bitmap_info.bmiHeader)
.biWidth = W
.biHeight = H
bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
31) \ 32) * 4)
pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
* .biBitCount) + 7) \ 8)
.biSizeImage = bytes_per_scanLine * Abs(.biHeight)
End With
result.hdc = CreateCompatibleDC(0)
lBmp = CreateCompatibleBitmap(result.hdc, W, H)
DeleteObject (SelectObject(result.hdc, result.hBM))
DeleteObject (lBmp)
result.wid = W
result.hgt = H
MakeMemoryBitmap = result
End Function
