人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

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

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

●質問者: lionfan
●カテゴリ:コンピュータ
✍キーワード:point POWER RGB VBA ピクセル
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● Mook
●100ポイント

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

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


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

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

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


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

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


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

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

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


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

◎質問者からの返答

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

30分ほどいじくって、

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

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

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


2 ● Mook
●150ポイント ベストアンサー

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

改善点は、

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

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

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美には「こんなの回答じゃないわ」っていわれそうですが、

ご参考までに。

◎質問者からの返答

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

B美も喜んでいます!!

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ