Question

我有一个要求，我需要在其中一个单元格中获取图片的颜色。

理想情况下，我想通过VBA代码执行此操作，但如果存在公式，我会很满意。

请参阅随附的屏幕截图。

在这种情况下，我想要以下选项之一

将每个黑匣子图片替换为假，并将白盒图片替换为True
有一个我可以输入D列的公式来描述图片的颜色。

非常感谢任何帮助。

谢谢，标记

Screenshot Of Example

Answer 1

这是一个野兽，因为我们必须打出一堆windows库来获取单元格左上角的绝对位置，抓取像素，找出颜色，并将其转储回工作簿。< / p>

我刚做了一个＆＃34;分配宏＆＃34;在单元格D2中的图片，所以当我点击它时，这将在单元格A1中粘贴相同的颜色。你可以随意使用它来做它你需要的东西，但是所有必要的垃圾都可以用来做它。

#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 GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () 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 GetWindowDC Lib "user32" (ByVal hwnd 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 Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type


Private Function ScreenDPI(bVert As Boolean) As Long
    'in most cases this simply returns 96
    Static lDPI&(1), lDC&
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, 88&)    'horz
        lDPI(1) = GetDeviceCaps(lDC, 90&)    'vert
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / 72
End Function

Private Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
    Dim wnd As Window

    'requires additional code to verify the range is visible
    'etc.

    Set wnd = rng.Parent.Parent.Windows(1)
    With rng
        rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) _
                  + wnd.PointsToScreenPixelsX(0)
        rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) _
                 + wnd.PointsToScreenPixelsY(0)
        rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) _
                   + rc.Left
        rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) _
                    + rc.Top
    End With
End Sub

Sub CellColor(cellRange As Range)

    Dim lColour As Long
    Dim lDC As Variant
    lDC = GetWindowDC(0)

    'Grab the pixel that we will use to determine the color
    Dim rc As RECT
    Dim xPos As Integer
    Dim yPos As Integer
    Call GetRangeRect(cellRange, rc)
    xPos = rc.Left
    yPos = rc.Top

    lColour = GetPixel(lDC, xPos, yPos)
    Debug.Print xPos, yPos, lColour

    Sheet1.Range("a1").Interior.Color = lColour

End Sub

Sub Picture1_Click()
    CellColor Sheet1.Range("D2")
End Sub

期待在Excel中获取图片的颜色

1 个答案: