Minh Tuan VN
New Member
- Joined
- Jul 31, 2024
- Messages
- 2
- Office Version
- 365
- Platform
- Windows
- Mobile
Hi friends,
I am a newbe. I would like your help in editing the Excel VBA code to do my job as follows:
- Step 1: I insert the image into the Excel file (in my sample the image is too small with dimensions of 21.75 width and 7.5 height by 7.5, unit is pixels).
- Step 2: Assign images to macros.
- Step 3: After clicking on the image, the macro runs and selects each pixel of the image and prints the color value of that pixel as R, G, B in columns A, B, C and prints the size of the image in cell E1 and F1.
The result of my VBA code is wrong: The image has many colors but the R, G, B values are the same R=255, G=0, B=0.
Please help me fix it. Thanks so much in advance!
Below is my code:
#If VBA7 Then
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y 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
#End If
Private Type POINT
x As Long
y As Long
End Type
Private Type rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub ExtractImageRGB()
Dim shp As Shape
Dim imgTop As Single, imgLeft As Single
Dim imgWidth As Single, imgHeight As Single
Dim x As Long, y As Long
Dim lColour As Long
Dim r As Integer, g As Integer, b As Integer
Dim cellRow As Long
Dim hdc As LongPtr
Dim rect As rect
' Get the shape (picture) from the worksheet
Set shp = ActiveSheet.Shapes("Picture 1") ' Change to your picture's name
' Get image bounds
imgTop = shp.Top
imgLeft = shp.Left
imgWidth = shp.Width
imgHeight = shp.Height
' Get the device context of the Excel window
hdc = GetDC(ActiveWindow.hwnd)
' Find the next empty row in column A
cellRow = 1
' Loop through each pixel within the image bounds
For y = 0 To imgHeight - 1
For x = 0 To imgWidth - 1
' Calculate pixel coordinates relative to the top-left corner of the image
lColour = GetPixel(hdc, imgLeft + x, imgTop + y)
' Extract RGB components from the color
r = lColour And &HFF
g = (lColour \ &H100) And &HFF
b = (lColour \ &H10000) And &HFF
' Output RGB values to cells
Cells(cellRow, 1).Value = r
Cells(cellRow, 2).Value = g
Cells(cellRow, 3).Value = b
' Fill cell ben canh bang picked color
Cells(cellRow, 4).Interior.Color = lColour
Range("E1").Value = imgWidth
Range("F1").Value = imgHeight
cellRow = cellRow + 1
Next x
Next y
' Release the device context
ReleaseDC ActiveWindow.hwnd, hdc
End Sub
I am a newbe. I would like your help in editing the Excel VBA code to do my job as follows:
- Step 1: I insert the image into the Excel file (in my sample the image is too small with dimensions of 21.75 width and 7.5 height by 7.5, unit is pixels).
- Step 2: Assign images to macros.
- Step 3: After clicking on the image, the macro runs and selects each pixel of the image and prints the color value of that pixel as R, G, B in columns A, B, C and prints the size of the image in cell E1 and F1.
The result of my VBA code is wrong: The image has many colors but the R, G, B values are the same R=255, G=0, B=0.
Please help me fix it. Thanks so much in advance!
Below is my code:
#If VBA7 Then
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y 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
#End If
Private Type POINT
x As Long
y As Long
End Type
Private Type rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub ExtractImageRGB()
Dim shp As Shape
Dim imgTop As Single, imgLeft As Single
Dim imgWidth As Single, imgHeight As Single
Dim x As Long, y As Long
Dim lColour As Long
Dim r As Integer, g As Integer, b As Integer
Dim cellRow As Long
Dim hdc As LongPtr
Dim rect As rect
' Get the shape (picture) from the worksheet
Set shp = ActiveSheet.Shapes("Picture 1") ' Change to your picture's name
' Get image bounds
imgTop = shp.Top
imgLeft = shp.Left
imgWidth = shp.Width
imgHeight = shp.Height
' Get the device context of the Excel window
hdc = GetDC(ActiveWindow.hwnd)
' Find the next empty row in column A
cellRow = 1
' Loop through each pixel within the image bounds
For y = 0 To imgHeight - 1
For x = 0 To imgWidth - 1
' Calculate pixel coordinates relative to the top-left corner of the image
lColour = GetPixel(hdc, imgLeft + x, imgTop + y)
' Extract RGB components from the color
r = lColour And &HFF
g = (lColour \ &H100) And &HFF
b = (lColour \ &H10000) And &HFF
' Output RGB values to cells
Cells(cellRow, 1).Value = r
Cells(cellRow, 2).Value = g
Cells(cellRow, 3).Value = b
' Fill cell ben canh bang picked color
Cells(cellRow, 4).Interior.Color = lColour
Range("E1").Value = imgWidth
Range("F1").Value = imgHeight
cellRow = cellRow + 1
Next x
Next y
' Release the device context
ReleaseDC ActiveWindow.hwnd, hdc
End Sub
