I'd like to change the cell's color accordingly to the pixel from a
image file with a loader routine for the image file.
Example:
cell(a1).backcolor=pixel(1)
cell(a2).backcolor=pixel(2)

where I can find samples for this?
[]'s
BD

Well how can I read each rgb pixel from a image file, please anyone?


On Sat, 25 Nov 2006 14:55:47 +0000, BD wrote:

>I'd like to change the cell's color accordingly to the pixel from a
>image file with a loader routine for the image file.
>Example:
>cell(a1).backcolor=pixel(1)
>cell(a2).backcolor=pixel(2)
>
>where I can find samples for this?
>[]'s
>BD
[]'s
BD

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