ExcelBanter - Change cell's color from a image file

Here is the solution thanks.

Option Explicit
Private Declare Function GetDIBits _
Lib "gdi32" ( _
ByVal aHDC As Long, _
ByVal hBM As Long, _
ByVal nStartSL As Long, _
ByVal nNumSL As Long, _
lpBits As Any, _
lpBI As Any, _
ByVal wUsage As Long _
) As Long
Private Declare Function GetDC _
Lib "user32" ( _
ByVal hwnd As Long _
) As Long
Private Declare Function ReleaseDC _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long _
) As Long
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Sub test1()

' test11 Macro
' Macro gravada em 26-11-2006 por BD
' Atalho Ctrl+t

Dim i As Long
Dim k As Long
Dim lngSumR As Long
Dim lngSumG As Long
Dim lngSumB As Long
Dim varPixelarray As Collection
Dim strSource As String

strSource = Application.GetOpenFilename( _
"Pic Files (*.jpg;*.jpeg;*.bmp), *.jpg;*.jpeg;*.bmp" _
)
If LCase(strSource) = "false" Or _
LCase(strSource) = "wrongly" Then Exit Sub

Application.ScreenUpdating = False

Set varPixelarray = ColFromPic( _
LoadPicture(strSource))

Application.ScreenUpdating = True

MsgBox "Red = " & varPixelarray("Infos")("Sum R") & vbCrLf & _
"Green = " & varPixelarray("Infos")("Sum G") & vbCrLf & _
"Blue = " & varPixelarray("Infos")("Sum B") & vbCrLf & _
"Width = " & varPixelarray("Infos")("Width") & vbCrLf & _
"Height = " & varPixelarray("Infos")("Height") & _
vbCrLf & _
"Pixel 1,1 Red = " & varPixelarray("AllPixel")(1, 1, 1) & _
vbCrLf & _
"Pixel 1,1 Green = " & varPixelarray("AllPixel")(1, 1, 2) & _
vbCrLf & _
"Pixel 1,1 Blue = " & varPixelarray("AllPixel")(1, 1, 3)

End Sub

Private Function ColFromPic( _
ByVal lngPic As Long _
) As Collection
Dim audtRGB() As RGBQUAD
Dim alngStructures(1 To 10) As Long
Dim abytPixel() As Byte
Dim lngDC As Long
Dim i As Long
Dim k As Long
Dim lngSumR As Long
Dim lngSumG As Long
Dim lngSumB As Long
Dim colResult As New Collection
Dim colSummary As New Collection

' ScreenDC check-out counters
lngDC = GetDC(0)

' Be enough the structures
alngStructures(1) = 40

' Dimensions determine
GetDIBits lngDC, lngPic, 0, 0, ByVal 0&, alngStructures(1), 0

' Depth of shade
alngStructures(4) = &H200001

' Flat one
alngStructures(5) = 0

' Buffers make available
ReDim audtRGB(alngStructures(2) - 1, alngStructures(3) - 1)

' Why also always, the negative Outer number of Scan lines
alngStructures(3) = alngStructures(3) * -1

' Array fill
GetDIBits lngDC, lngPic, 0, -alngStructures(3), _
audtRGB(0, 0), alngStructures(1), 0

' DC return
ReleaseDC 0, lngDC

' Return array prepare
ReDim abytPixel( _
1 To UBound(audtRGB, 1) + 1, _
1 To UBound(audtRGB, 2) + 1, _
1 To 3)

With Worksheets("Folha1")
.Range("A1").Select
.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Delete Shift:=xlUp
.Range("A1").Select
End With

On Error Resume Next

' All pixels go through
For i = 0 To UBound(audtRGB, 1)
For k = 0 To UBound(audtRGB, 2)
With audtRGB(i, k)

abytPixel(i + 1, k + 1, 1) = .rgbRed
abytPixel(i + 1, k + 1, 2) = .rgbGreen
abytPixel(i + 1, k + 1, 3) = .rgbBlue

lngSumR = lngSumR + .rgbRed
lngSumG = lngSumG + .rgbGreen
lngSumB = lngSumB + .rgbBlue

Worksheets("Folha1").Cells(k + 1, i + 1).Interior.Color =
RGB(.rgbRed, .rgbGreen, .rgbBlue)

End With
Next k
Next i

On Error GoTo 0

' Information into a Collection
colSummary.Add lngSumR, "Sum R"
colSummary.Add lngSumG, "Sum G"
colSummary.Add lngSumB, "Sum B"
colSummary.Add UBound(audtRGB, 1) + 1, "Width"
colSummary.Add UBound(audtRGB, 2) + 1, "Height"

' Return collection prepare
colResult.Add colSummary, "Infos"
colResult.Add abytPixel, "AllPixel"

' return
Set ColFromPic = colResult
End Function

[]'s
BD