トップ　>　備忘録　>　ビットマップ画像の色の取得

'///宣言セクションに記述///
#If VBA7 Then
    'Excel2010以上
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _
        ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" ( _
        ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hDC As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
    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 LoadImage Lib "user32" Alias "LoadImageA" ( _
        ByVal hinst As LongPtr, _
        ByVal lpszName As String, _
        ByVal uType As Long, _
        ByVal cxDesired As Long, _
        ByVal cyDesired As Long, _
        ByVal fuLoad As Long) As LongPtr
#Else
    Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
        ByVal hDC As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" ( _
        ByVal hDC As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" ( _
        ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal hgdiobj As Long) As Long
    Private Declare Function GetPixel Lib "gdi32" ( _
        ByVal hDC As Long, _
        ByVal x As Long, _
        ByVal y As Long) As Long
    Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
        ByVal hinst As Long, _
        ByVal lpszName As String, _
        ByVal uType As Long, _
        ByVal cxDesired As Long, _
        ByVal cyDesired As Long, _
        ByVal fuLoad As Long) As Long
#End If
Private Const LR_LOADFROMFILE = &H10
Type FileWH
    w As Long
    h As Long
    ERROR As String
End Type
'///ここまで///
Sub Get_BMP_Sample()
    Dim strPS As String
    Dim strFP As String
    Dim typFWH As FileWH
    strPS = Application.PathSeparator
    strFP = DeskTop_Path() & strPS & "sample.bmp"
    typFWH = Check_FileSize(strFP)
    With typFWH
        If .ERROR <> "" Then
            MsgBox .ERROR, vbExclamation + vbOKOnly: Exit Sub
        End If
        Call Load_BMP_Image(strFP, .w, .h)
    End With
End Sub

Private Function DeskTop_Path() As String
    Dim objWShell As Object 'WScript.Shell
    Set objWShell = CreateObject("WScript.Shell")
    'デスクトップパス
    DeskTop_Path = objWShell.SpecialFolders("Desktop")
End Function

Private Function Check_FileSize(ByVal FP As String) As FileWH
    Dim objImage As Object
    On Error GoTo ERROR
        Set objImage = LoadPicture(FP)
        With Check_FileSize
            .w = CLng(objImage.Width * 0.0378)
            .h = CLng(objImage.Height * 0.0378)
            If .w < 321 And .h < 321 Then Exit Function
            .ERROR = "処理対応上限を超えています" & vbCrLf _
                            & "最大処理対応ピクセル：240×320"
        End With
    On Error GoTo 0
Exit Function
ERROR:
    Check_FileSize.ERROR = "ファイルが存在しない、またはファイル形式が対象外、" _
                    & vbCrLf & "又はフォルダへのアクセスが制限されています。"
End Function

Private Sub Load_BMP_Image(file As String, w As Long, h As Long)
    Dim intI As Long
    Dim intII As Long
    Dim oldBmp As Long
    Dim DC, bmp
    DC = CreateCompatibleDC(0) 'スクリーンDCに関連あるDCを作成
    bmp = LoadImage(0, file, 0, 0, 0, LR_LOADFROMFILE) 'BMP読込
    oldBmp = SelectObject(DC, bmp) '作成したDCにbmpを関連付ける
    With Application
        .ScreenUpdating = False
        With .ActiveWorkbook.ActiveSheet
            With .Cells
                .Clear
                .ColumnWidth = 0.23
                .RowHeight = 2.25
            End With
            If .Columns.Count < w Then w = .Columns.Count
            For intI = 1 To h
                For intII = 1 To w
                    .Cells(intI, intII).Interior.Color = GetPixel(DC, intII - 1, intI - 1)
                Next
            Next
        End With
        .ScreenUpdating = True
    End With
    bmp = SelectObject(DC, oldBmp)
    Call DeleteDC(DC)
    Call DeleteObject(bmp)
End Sub