• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
Worf

VBA – Transferring picture to worksheet pixel by pixel

Excel Version
  1. 2016
Say that you want to analyze the color distribution of a given picture. One way to do this is to have each worksheet cell representing one image pixel.

To use the code, run the transfer routine, specifying the sheet and the shape name.

lots of pixels.PNG


VBA Code:
#If VBA7 Then
 Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
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 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
Type POINTAPI
    x As Long
    y As Long
End Type
Type Size
    Width As Long
    Height As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc&, ByVal hObject&) 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc&, ByVal x&, ByVal y&) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat%) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
 
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const CLR_INVALID = &HFFFF
Private Function GetPixelColorFromShape(ByVal Shp As Shape, _
ByRef Pt As POINTAPI, ByRef WidthHeight As Size) As Long
    Dim oPic As StdPicture
    Set oPic = PicFromShape(Shp)
    If oPic <> 0 Then GetPixelColorFromShape = PixelFromPoint(oPic, Pt, WidthHeight)
End Function

Private Function PixelFromPoint(ByVal Pic As StdPicture, ByRef Pt As POINTAPI, _
ByRef WidthHeight As Size) As Long
    Dim memDC As Long, tBm As BITMAP
    memDC = CreateCompatibleDC(0)
    Call SelectObject(memDC, Pic.Handle)
    Call GetObjectAPI(Pic.Handle, LenB(tBm), tBm)
    WidthHeight.Width = tBm.bmWidth - 1: WidthHeight.Height = tBm.bmHeight - 1
    PixelFromPoint = GetPixel(memDC, Pt.x, Pt.y)
    Call DeleteDC(memDC)
End Function

Private Function PicFromShape(Shp As Shape) As StdPicture
    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc, IPic As StdPicture, hPtr&
    Shp.CopyPicture xlScreen, xlBitmap
    Sleep 40
    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
    Set PicFromShape = IPic
End Function

Sub Transfer()
Dim lPixelColor, tPt As POINTAPI, tPicSize As Size, i, j, im, jm
tPt.x = 23
tPt.y = 12
lPixelColor = GetPixelColorFromShape(Sheet6.Shapes("Picture 2"), tPt, tPicSize)
im = tPicSize.Height
jm = tPicSize.Width
Application.ScreenUpdating = False
For i = 1 To im
    For j = 1 To jm
        tPt.x = j
        tPt.y = i
        lPixelColor = GetPixelColorFromShape(Sheet6.Shapes("Picture 2"), tPt, tPicSize)
        Sheets("map").Cells(i, j).Interior.Color = lPixelColor
Next j, i
Application.ScreenUpdating = True
End Sub
'********************
Author
Worf
Views
6,440
First release
Last update
Rating
0.00 star(s) 0 ratings

More Excel articles from Worf

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top