[[20210625150733]]　『VBAでヒートマップを設定してるセルの背景色取得』（tri）　ページの最後に飛ぶ

『VBAでヒートマップを設定してるセルの背景色取得』（tri）

条件式書式である領域のヒートマップを設定しています。
その領域内の任意の場所の背景色をRGBで取得したいのですが、条件式書式では実際のセルの背景色が変わっているわけではない(Cells.Interior.Colorは透明のまま)ので、通常のやり方では色の取得ができません。

どのように行えばよいでしょうか。

＜使用 Excel：Excel2007、使用 OS：Windows10 ＞

Excel2010以降であれば、DisplayFormatというのが使えて、例えば、

    Dim r As Range
    For Each r In Selection
        Debug.Print r.DisplayFormat.Interior.Color
    Next
といった芸当ができるのですが、2007だと難しいですね。

Wordに一旦貼り付けて、それを元に戻せば、
Cells.Interior.Color　で普通に取得できると思いますけどねえ。
（γ） 2021/06/25(金) 15:33

2010以降だとできるのですね、、、バージョン変更を検討いたします。
早速のご回答どうもありがとうございました。
（tri） 2021/06/25(金) 15:41

こちらのやり方で簡単に乗り切れましたので、当面これで対応します。

＞Wordに一旦貼り付けて、それを元に戻せば、
＞Cells.Interior.Color　で普通に取得できると思いますけどねえ。

ナイスなノウハウどうもありがとうございました！
（tri） 2021/06/25(金) 16:35

 解決後ですがAPIで足掻いてみました。 (参考にすらならない無駄投稿スマセン^^;)

 ActiveCellをCopyPictureして、クリップボードのビットマップから各ピクセルのRGB値を配列で取ってくる。
 という相当な力技コードで、ようやく「うーん、出来なくもないけど...」というレベルですね。

    Option Explicit
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Const CF_BITMAP As Long = 2
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
    End Type
    Private Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
    End Type
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" ( _
        ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, _
        lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Const DIB_RGB_COLORS = 0&

    Private Function GetBmpfromClipbpard() As LongPtr
        If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Function
        If OpenClipboard(0&) <> 0 Then
            GetBmpfromClipbpard = GetClipboardData(CF_BITMAP)
            Call CloseClipboard
        End If
    End Function
    Private Function GetRGBsofBmp(ByVal hBmp As LongPtr, pxWidth As Long, pxHeight As Long) As Variant
        Dim Rtn As LongPtr
        Dim bi As BITMAPINFO
        Dim hDC As LongPtr, hOld As LongPtr
        Dim RGBBuff() As Byte, r As Long, c As Long, vRGB() As Variant
        hDC = CreateCompatibleDC(0&)
        hOld = SelectObject(hDC, hBmp)
        With bi.bmiHeader
            .biSize = Len(bi.bmiHeader)
            .biWidth = pxWidth
            .biHeight = -pxHeight
            .biPlanes = 1
            .biBitCount = 32
            .biSizeImage = pxWidth * 4 * pxHeight
        End With
        ReDim RGBBuff(1 To pxWidth * 4, 1 To pxHeight)
        Rtn = GetDIBits(hDC, hBmp, 0&, pxHeight, RGBBuff(1, 1), bi, DIB_RGB_COLORS)
        Call SelectObject(hDC, hOld)
        Call DeleteDC(hDC)
        If Rtn = 0 Then Exit Function
        ReDim vRGB(1 To pxHeight, 1 To pxWidth)
        For r = 1 To pxHeight
            For c = 1 To pxWidth
                vRGB(r, c) = RGBBuff(c * 4 - 1, r) + RGBBuff(c * 4 - 2, r) * &H100& + RGBBuff(c * 4 - 3, r) * &H100& ^ 2
            Next
        Next
        GetRGBsofBmp = vRGB
    End Function

    Sub Test()
        Dim c As Range
        Dim hBmp As LongPtr
        Dim Ary() As Variant

        Set c = ActiveCell
        c.CopyPicture xlScreen, xlBitmap
        hBmp = GetBmpfromClipbpard
        Ary = GetRGBsofBmp(hBmp, 2, 2)                        '左上から2x2ピクセル分取って、
        Debug.Print Ary(2, 2); "(&H" & Hex(Ary(2, 2)) & ")"   'その4つ目(右下)のRGB値
    End Sub

（白茶） 2021/06/25(金) 16:39

すさまじいコード量…　力作をありがとうございました。
残念ながら私ではメンテが出来ないので採用はできないと思いますが、根性があれば何とかなるもんだなと思いました。
今後の参考にさせていただきます。
（tri） 2021/06/25(金) 19:59

コメント返信：

[ 一覧(最新更新順) ]

[[20210625150733]] 『VBAでヒートマップを設定してるセルの背景色取得』（tri） ページの最後に飛ぶ

[[20210625150733]]　『VBAでヒートマップを設定してるセルの背景色取得』（tri）　ページの最後に飛ぶ