色センサーを求めて - インストールレスプログラミング( ´ー`)

まだ，玉のやつはあきらめていませんが，

いろいろと，手段を手にいれようと考え中です。

図形の合成をすることで，当たり判定をしたのは面白い手段だと思っています。

でも，あれ以外にも感知，判断する方法を探そうと思って色を判断する方法を探しました。

www.excel.studio-kazu.jp

こちらのページで，マウスカーソル位置のピクセルを取得する方法を見つけました。

これなら，うまく作り直せば，知りたい場所の色を知ることができるので，坂道と接触しているかどうか判断できるかなぁと考えました。

このコードを利用させてもらい，マウスカーソル位置の色を取得し，パワーポイントに表示するものを作ってみました。

もっとコンパクトに必要な機能だけにまとめて，また坂道の話にいつか挑みたいな。

スライド１に txtという名のテキストボックス，StopMacroを関連付けたボタン，tableという名の５行１列の表を置きます。
f:id:chemiphys:20170124203144p:plain

標準モジュールに下記のコードを貼り付けます。

Option Explicit
Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmiliseconds As Long)
Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Declare PtrSafe Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal nXPos As Long, ByVal nYPos As Long) As Long
Type POINTAPI
   X As Long
   Y As Long
End Type
Dim blnStop As Boolean
 
 
Sub GetColor()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(1)
    Dim RTable As Table: Set RTable = TSlide.Shapes("table").Table
    Dim TShp As Shape: Set TShp = TSlide.Shapes("txt")
    Dim hdc As Long, Color As Long
    Dim pt As POINTAPI
    Dim i As Long
    
    ActivePresentation.SlideShowSettings.Run
    SlideShowWindows(1).View.PointerType = ppSlideShowPointerArrow
    blnStop = False
    
    Do
        Call GetCursorPos(pt)
        hdc = GetDC(0)
        Color = GetPixel(hdc, pt.X, pt.Y)
        Call ReleaseDC(0, hdc)
    
        Dim R As Byte, G As Byte, B As Byte
        R = Color And &HFF
        G = Color \ &H100 And &HFF
        B = Color \ &H10000 And &HFF
        
        TShp.TextFrame.TextRange = "(" & pt.X & "," & pt.Y & ") " & R & ", " & G & ", " & B
        TShp.TextFrame.TextRange.Font.Color.RGB = RGB(255 - R, 255 - G, 255 - B)
        TShp.Fill.ForeColor.RGB = RGB(R, G, B)
        
        Sleep 50
                
        DoEvents
        
        If GetAsyncKeyState(vbKeyShift) <> 0 Then
            i = 1
            Do
                If RTable.Cell(i, 1).Shape.TextFrame.TextRange = "" Then Exit Do
                i = i + 1
            Loop Until i = 6
            
            If i = 6 Then
                RTable.Rows.Add
                RTable.Rows(1).Delete
                i = 5
            End If
            
            With RTable.Cell(i, 1).Shape
                .TextFrame.TextRange = TShp.TextFrame.TextRange
                .Fill.ForeColor.RGB = RGB(R, G, B)
                .TextFrame.TextRange.Font.Color.RGB = RGB(255 - R, 255 - G, 255 - B)
            End With
        End If
        If blnStop = True Then Exit Do
    Loop
    
    SlideShowWindows(1).View.Exit
End Sub

Sub StopMacro()
    blnStop = True
End Sub