Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Change cell's color from a image file
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Change cell's color from a image file
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Have row color change to one of 8 different colors based on one cell's value (I, O, C, T, L, E, X, A) | Excel Discussion (Misc queries) | |||
In Excel is there a function to change a cell's background color? | Excel Worksheet Functions | |||
change cell background color when another cell's value = 40 | Excel Discussion (Misc queries) | |||
Change a cell's fill color dynamically? | Excel Discussion (Misc queries) | |||
how do I change the color of a cell dependant upon the cell's con. | Excel Programming |