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

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

改善点は、

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

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

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ビット（フルカラーモード）でなければ、正常に動作しません。

等です。

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

ご参考までに。