Power PointのVBAに関する質問です。

現在、1つのシェイプもしくは図をマウスで選択している状態だとします。

で、そのシェイプもしくは図のx, y座標の1ピクセルの色(RGB値)をゲットしたいのですが、
どのようにすれば可能でしょうか。

ご教示いただければと思います。
よろしくおねがいいたします。
(なおプログラム中で利用するので、フリーソフト等の紹介は必要ありません)

回答の条件
  • 1人2回まで
  • 登録:2006/11/24 22:38:22
  • 終了:2006/11/28 12:53:26

ベストアンサー

id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912006/11/28 12:39:26

ポイント150pt

まだ締め切られていないようなので、前回の問題点を多少改善してみました。

改善点は、

・スライドの開始位置をプログラム中で設定するようにしました(力技なのでもっとスマートにしたいところですが・・・)

・表示倍率を任意の倍率で計算できるように改善

Option Explicit
'--------------------------------------------------------------------
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetPixel Lib "gdi32" _
                 (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function GetClientRect Lib "user32.dll" _
                 (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'--------------------------------------------------------------------
Type RECT  '// Window サイズ用の型
      Left As Long   '// 幅    = Right - Left
      Top  As Long
      Right  As Long '// 高さ  = Bottom - Top
      Bottom As Long
End Type

'--------------------------------------------------------------------
Type POINTAPI '// 座標用の型
    X As Long '// X座標
    Y As Long '// Y座標
End Type

Public slideOffset As POINTAPI

'--------------------------------------------------------------------
Public Sub mainSample()
'--------------------------------------------------------------------
'// スライドの基点を取得
'// あまり使いたくないけどとりあえず大域変数に保存
    slideOffset = getSlideBase()
    If slideOffset.X < 0 Or slideOffset.Y < 0 Then
        MsgBox "スライドの基点を設定できませんでした。"
        Exit Sub
    End If
    
    '// 選択されているオートシェイプの左上の色を取得するサンプル
    Dim sp As Shape
    For Each sp In ActiveWindow.Selection.ShapeRange
        getShapePixColor sp, 3, 3
    Next
End Sub

'--------------------------------------------------------------------
Sub getShapePixColor(ByRef sp As Shape, posX As Long, posY As Long)
'--------------------------------------------------------------------
'// オートシェイプの左上からの座標位置を指定して色を取得
    Dim spPoint As POINTAPI
    spPoint.X = posX
    spPoint.Y = posY

    '// 指定した位置がオートシェイプの範囲内かチェック
    If posX < 0 Or PtToPx(sp.width) < posX _
      Or posY < 0 Or PtToPx(sp.height) < posY Then
        MsgBox "指定した位置がオートシェイプ外です。"
        Exit Sub
    End If

    Dim pixelColor As Long
    '// RGB の配列は 00BBGGRR : 通常と逆なので注意
    pixelColor = getShapeColorAPI(sp, spPoint)
    If pixelColor = -1& Then
        Debug.Print "GetPixel Error"
    Else
        Debug.Print "WINDOW 座標 (" & slideOffset.X + PtToPx(sp.Left) + posX & "," _
            & slideOffset.Y + PtToPx(sp.Top) + posY & ") : スライド座標(" & sp.Left & "," & sp.Top & ")" _
            & " = &H" & Right("000000" & Hex(pixelColor), 6)
    End If
End Sub

'--------------------------------------------------------------------
Private Function getShapeColorAPI(sp As Shape, point As POINTAPI) As Long
'--------------------------------------------------------------------
'// オートシェイプ sp の point 位置の色を取得
    Dim hWnd As Long
    hWnd = GetActiveWindow()
    If hWnd = 0 Then
        getShapeColorAPI = -1
        Exit Function
    End If

    Dim hdc As Long
    hdc = GetWindowDC(hWnd)
    getShapeColorAPI = GetPixel(hdc, slideOffset.X + PtToPx(sp.Left) + point.X, slideOffset.Y + PtToPx(sp.Top) + point.Y)
End Function

'--------------------------------------------------------------------
Function PtToPx(X As Double) As Long
'--------------------------------------------------------------------
'// 座標変換:表示倍率を考慮
    PtToPx = CLng(X * 96# / 72# * CDbl(ActiveWindow.View.Zoom) / 100#)
End Function

'--------------------------------------------------------------------
'// 以下スライド基点取得用の関数
'--------------------------------------------------------------------
Private Function getSlideBase() As POINTAPI
'--------------------------------------------------------------------
'// スライドの基点にオブジェクトを置き、Window 座標上でその位置を検索
'// フルカラーモードで動かすこと:近似色で表示されると検出できない
    Dim markerColor As Long
    markerColor = RGB(241, 113, 23) '// おまじない程度に計算で出にくい素数を使用
    Dim markerShape As Shape
    Set markerShape = setMarker(markerColor)
    If MsgBox("マーカは表示されましたか", vbYesNo) = vbYes Then
        Sleep 300 '// 一応アクティブウィンドウが切り替わるまでWAITを挿入
    Else
        Exit Function
    End If
    Dim offsetPos As POINTAPI
    offsetPos.X = 0
    offsetPos.Y = 0
    
    Dim hWnd As Long
    hWnd = GetActiveWindow()
    If hWnd = 0 Then
        getSlideBase = offsetPos
        MsgBox "ハンドルが取得できませんでした。"
        Exit Function
    End If
    
    offsetPos = findColor(hWnd, markerColor)
    getSlideBase = offsetPos
    markerShape.Delete
End Function

'--------------------------------------------------------------------
Private Function setMarker(sRGB As Long) As Shape
'--------------------------------------------------------------------
'// スライドの基点(0,0)にオブジェクトを作成
    Dim sp As Shape
    Set sp = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 0, 0, 10, 10)
    With sp
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = sRGB
        .Fill.Transparency = 0#
        .Line.Visible = msoFalse
    End With
    Set setMarker = sp
End Function

'--------------------------------------------------------------------
Private Function findColor(hWnd As Long, searchColor As Long) As POINTAPI
'--------------------------------------------------------------------
'// 左上からスキャンし、指定した色の最初の座標を取得
    Dim hdc As Long
    hdc = GetWindowDC(hWnd)

    Dim lpRect As RECT
    Dim rc As Long
    rc = GetClientRect(hWnd, lpRect)

    Dim resPos As POINTAPI
    resPos.X = -1
    resPos.Y = -1

    Dim X As Long
    Dim Y As Long
    For Y = 0 To lpRect.Bottom
        For X = 0 To lpRect.Right
            If GetPixel(hdc, X, Y) = searchColor Then
                resPos.X = X
                resPos.Y = Y
                findColor = resPos
                Exit Function
            End If
        Next
    Next
    findColor = resPos
End Function

残問題は、

・スライドの左上が表示されていない場合動作しません。

・画面の表示モードが32ビット(フルカラーモード)でなければ、正常に動作しません。

等です。


B美には「こんなの回答じゃないわ」っていわれそうですが、

ご参考までに。

id:lionfan

Mook様、すばらしいプログラムありがとうございます!!

B美も喜んでいます!!

2006/11/28 12:52:59

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912006/11/26 22:29:10

ポイント100pt

この質問には私も注目しているのですが、なかなか回答が付かないようなので中途半端な情報ですみませんが、試してみた範囲で回答させていただきます。

役に立たなかった場合は、ポイントは不要です。


一応下記のようなコードでカラー値を取得することができます。

Option Explicit
'--------------------------------------------------------------------
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetPixel Lib "gdi32" _
                 (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long

'--------------------------------------------------------------------
Public Sub dumpPixel()
'--------------------------------------------------------------------
'// 対象となるスライドを表示してPowerPoint 上で実行
    Dim sp As Shape
    For Each sp In ActiveWindow.Selection.SlideRange.Shapes
        getPixColor PtToPx(sp.Left), PtToPx(sp.Top)
    Next
End Sub

'--------------------------------------------------------------------
Function PtToPx(x As Double ) As Long
'--------------------------------------------------------------------
'// 座標変換:表示倍率 100%以外では縮小率を考慮する必要がある
    PtToPx = CLng( x * 96# / 72# )
End Function

'--------------------------------------------------------------------
Private Sub getPixColor(startX As Long, startY As Long)
'--------------------------------------------------------------------
' // 画像の左上を中心とした9x9 ピクセルの色情報を表示
    Dim hWnd As Long
    hWnd = GetActiveWindow()
    If hWnd = 0 Then
        MsgBox "Window Handle 取得エラー"
        Exit Sub
    End If

    Dim hdc As Long
    hdc = GetWindowDC(hWnd)

    
    Dim offsetX As Long
    Dim offsetY As Long

'// 実際のPoworPoint の作業領域の、PowerPoint のWindow 領域に対する位置
'// 自動取得を Give Up
'// とりあえず設定現在の環境を設定する。個々に調整が必要
    offsetX = 30
    offsetY = 109

    Dim x As Long
    Dim Y As Long
    Debug.Print "スライド上の位置 = (" &amp; startX &amp; "," &amp; startX &amp; ")"
    Dim Ret As String
    For Y = offsetY + startY - 4 To offsetY + startY + 4
        Ret = "(" &amp; offsetX + startX - 2 &amp; "," &amp; Y &amp; ") :"
        For x = offsetX + startX - 4 To offsetX + startX + 4
'// RGB の配列は 00BBGGRR : 通常と逆なので注意
           Ret = Ret &amp; Right("00000000" &amp; Hex(GetPixel(hdc, x, Y)), 8) &amp; " "
        Next
        Debug.Print Ret
    Next
End Sub

ただし、問題点がいくつかあります。


コメント中にも書きましたが、オートシェイプの座標はポイントという単位で管理されているのですが、Window の座標を指定する際にはピクセル単位の座標を指定する必要があります。

この、変換で計算上1ピクセルの誤差が出る場合があります。


また、PowerPoint のWindow の基底座標とスライドの基底座標が異なるため、これも考慮しなければなりません。

何とか自動で取得しようといろいろ探して見ましたが、良い情報がありませんでした。

なので、上記の例では手動で設定しています。


これらの問題のため部分的にしか参考にならないと思いますが、ご参考までに。

id:lionfan

Mook様、ありがとうございました。

30分ほどいじくって、

ようやくある程度、理解できたと思います。

すばらしいプログラムですね!!

ものすごーーく勉強になりました。

2006/11/27 01:25:50
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912006/11/28 12:39:26ここでベストアンサー

ポイント150pt

まだ締め切られていないようなので、前回の問題点を多少改善してみました。

改善点は、

・スライドの開始位置をプログラム中で設定するようにしました(力技なのでもっとスマートにしたいところですが・・・)

・表示倍率を任意の倍率で計算できるように改善

Option Explicit
'--------------------------------------------------------------------
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetPixel Lib "gdi32" _
                 (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function GetClientRect Lib "user32.dll" _
                 (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'--------------------------------------------------------------------
Type RECT  '// Window サイズ用の型
      Left As Long   '// 幅    = Right - Left
      Top  As Long
      Right  As Long '// 高さ  = Bottom - Top
      Bottom As Long
End Type

'--------------------------------------------------------------------
Type POINTAPI '// 座標用の型
    X As Long '// X座標
    Y As Long '// Y座標
End Type

Public slideOffset As POINTAPI

'--------------------------------------------------------------------
Public Sub mainSample()
'--------------------------------------------------------------------
'// スライドの基点を取得
'// あまり使いたくないけどとりあえず大域変数に保存
    slideOffset = getSlideBase()
    If slideOffset.X < 0 Or slideOffset.Y < 0 Then
        MsgBox "スライドの基点を設定できませんでした。"
        Exit Sub
    End If
    
    '// 選択されているオートシェイプの左上の色を取得するサンプル
    Dim sp As Shape
    For Each sp In ActiveWindow.Selection.ShapeRange
        getShapePixColor sp, 3, 3
    Next
End Sub

'--------------------------------------------------------------------
Sub getShapePixColor(ByRef sp As Shape, posX As Long, posY As Long)
'--------------------------------------------------------------------
'// オートシェイプの左上からの座標位置を指定して色を取得
    Dim spPoint As POINTAPI
    spPoint.X = posX
    spPoint.Y = posY

    '// 指定した位置がオートシェイプの範囲内かチェック
    If posX < 0 Or PtToPx(sp.width) < posX _
      Or posY < 0 Or PtToPx(sp.height) < posY Then
        MsgBox "指定した位置がオートシェイプ外です。"
        Exit Sub
    End If

    Dim pixelColor As Long
    '// RGB の配列は 00BBGGRR : 通常と逆なので注意
    pixelColor = getShapeColorAPI(sp, spPoint)
    If pixelColor = -1& Then
        Debug.Print "GetPixel Error"
    Else
        Debug.Print "WINDOW 座標 (" & slideOffset.X + PtToPx(sp.Left) + posX & "," _
            & slideOffset.Y + PtToPx(sp.Top) + posY & ") : スライド座標(" & sp.Left & "," & sp.Top & ")" _
            & " = &H" & Right("000000" & Hex(pixelColor), 6)
    End If
End Sub

'--------------------------------------------------------------------
Private Function getShapeColorAPI(sp As Shape, point As POINTAPI) As Long
'--------------------------------------------------------------------
'// オートシェイプ sp の point 位置の色を取得
    Dim hWnd As Long
    hWnd = GetActiveWindow()
    If hWnd = 0 Then
        getShapeColorAPI = -1
        Exit Function
    End If

    Dim hdc As Long
    hdc = GetWindowDC(hWnd)
    getShapeColorAPI = GetPixel(hdc, slideOffset.X + PtToPx(sp.Left) + point.X, slideOffset.Y + PtToPx(sp.Top) + point.Y)
End Function

'--------------------------------------------------------------------
Function PtToPx(X As Double) As Long
'--------------------------------------------------------------------
'// 座標変換:表示倍率を考慮
    PtToPx = CLng(X * 96# / 72# * CDbl(ActiveWindow.View.Zoom) / 100#)
End Function

'--------------------------------------------------------------------
'// 以下スライド基点取得用の関数
'--------------------------------------------------------------------
Private Function getSlideBase() As POINTAPI
'--------------------------------------------------------------------
'// スライドの基点にオブジェクトを置き、Window 座標上でその位置を検索
'// フルカラーモードで動かすこと:近似色で表示されると検出できない
    Dim markerColor As Long
    markerColor = RGB(241, 113, 23) '// おまじない程度に計算で出にくい素数を使用
    Dim markerShape As Shape
    Set markerShape = setMarker(markerColor)
    If MsgBox("マーカは表示されましたか", vbYesNo) = vbYes Then
        Sleep 300 '// 一応アクティブウィンドウが切り替わるまでWAITを挿入
    Else
        Exit Function
    End If
    Dim offsetPos As POINTAPI
    offsetPos.X = 0
    offsetPos.Y = 0
    
    Dim hWnd As Long
    hWnd = GetActiveWindow()
    If hWnd = 0 Then
        getSlideBase = offsetPos
        MsgBox "ハンドルが取得できませんでした。"
        Exit Function
    End If
    
    offsetPos = findColor(hWnd, markerColor)
    getSlideBase = offsetPos
    markerShape.Delete
End Function

'--------------------------------------------------------------------
Private Function setMarker(sRGB As Long) As Shape
'--------------------------------------------------------------------
'// スライドの基点(0,0)にオブジェクトを作成
    Dim sp As Shape
    Set sp = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 0, 0, 10, 10)
    With sp
        .Fill.Visible = msoTrue
        .Fill.ForeColor.RGB = sRGB
        .Fill.Transparency = 0#
        .Line.Visible = msoFalse
    End With
    Set setMarker = sp
End Function

'--------------------------------------------------------------------
Private Function findColor(hWnd As Long, searchColor As Long) As POINTAPI
'--------------------------------------------------------------------
'// 左上からスキャンし、指定した色の最初の座標を取得
    Dim hdc As Long
    hdc = GetWindowDC(hWnd)

    Dim lpRect As RECT
    Dim rc As Long
    rc = GetClientRect(hWnd, lpRect)

    Dim resPos As POINTAPI
    resPos.X = -1
    resPos.Y = -1

    Dim X As Long
    Dim Y As Long
    For Y = 0 To lpRect.Bottom
        For X = 0 To lpRect.Right
            If GetPixel(hdc, X, Y) = searchColor Then
                resPos.X = X
                resPos.Y = Y
                findColor = resPos
                Exit Function
            End If
        Next
    Next
    findColor = resPos
End Function

残問題は、

・スライドの左上が表示されていない場合動作しません。

・画面の表示モードが32ビット(フルカラーモード)でなければ、正常に動作しません。

等です。


B美には「こんなの回答じゃないわ」っていわれそうですが、

ご参考までに。

id:lionfan

Mook様、すばらしいプログラムありがとうございます!!

B美も喜んでいます!!

2006/11/28 12:52:59
  • id:Mook
    御存知かもしれませんが、& が &amp; に化けているので、
    もしお試しの際は修正ください。

    また、質問が選択している図形となっているのを、回答してから気が付きました。

    対象が、スライド上のすべてのオートシェイプになってしまっているので、御変更ください。

    駄回答ですみませんでした。
  • id:lionfan
    Mook様、大丈夫です。
    どちらも気づき修正した上で実行しております。
    お心遣いありがとうございます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません