Option Explicit

'=========================
' Windows API（座標変換用）
'=========================
#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
#End If

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

'=========================
' グローバル状態
'=========================
Public Enum MarkMode
    ModeStamp = 0
    ModeLine = 1
    ModeErase = 2
End Enum

Public Enum StampKind
    StampStar = 0     ' ★
    StampCircle = 1   ' ●
    StampSquare = 2   ' ■
    StampTriangle = 3 ' ▲
    StampCross = 4    ' ×（2本線）
End Enum

Public gMode As MarkMode
Public gStamp As StampKind
Public gSizePt As Single
Public gColor As Long

' 線の連続描画用
Private gHasPrev As Boolean
Private gPrevX As Single, gPrevY As Single

' クリック受け取り用シェイプ名
Private Const CLICK_CATCHER_NAME As String = "PPTMark_ClickCatcher"

' 作成図形の識別プレフィックス
Private Const TAG_STAMP As String = "PPTMARK_STAMP_"
Private Const TAG_LINE As String = "PPTMARK_LINE_"

'=========================
' 初期化と開始
'=========================
Public Sub PPTMark_Start()
    '先ず、全面消去で綺麗にする
    'Call PPTMark_ClearCurrentSlide
    ' 1) 各スライドにクリック受け取り図形を用意（最前面・透明・マクロ割当）
    SetupClickCatchersOnAllSlides

    ' 2) スライドショーをウィンドウ表示・手動進行で開始
    With ActivePresentation.SlideShowSettings
        .ShowType = ppShowTypeWindow        ' ウィンドウ内スライドショー [4](https://www.relief.jp/docs/powerpoint-vba-slideshow-in-window.html)
        .AdvanceMode = ppSlideShowManualAdvance
        .Run
    End With

    ' 3) 既定状態（HSP版に合わせて）
    gMode = ModeStamp
    gStamp = StampStar          ' ★
    gSizePt = 16                ' サイズ 16pt
    gColor = RGB(255, 0, 0)     ' 赤
    gHasPrev = False

    ' 4) パネルをモデルレス表示
    On Error Resume Next: Unload frmPanel: On Error GoTo 0
    frmPanel.Show vbModeless
    frmPanel.SyncUIFromGlobals
End Sub

'=========================
' 各スライドに透明のクリック受け取り図形を作成
'=========================
Private Sub SetupClickCatchersOnAllSlides()
    Dim sld As Slide, shp As Shape
    Dim W As Single, H As Single
    W = ActivePresentation.PageSetup.SlideWidth
    H = ActivePresentation.PageSetup.SlideHeight

    For Each sld In ActivePresentation.Slides
        Set shp = Nothing
        On Error Resume Next
        Set shp = sld.Shapes(CLICK_CATCHER_NAME)
        On Error GoTo 0

        If shp Is Nothing Then
            Set shp = sld.Shapes.AddShape(msoShapeRectangle, 0, 0, W, H)
            shp.Name = CLICK_CATCHER_NAME
        Else
            shp.Left = 0: shp.Top = 0: shp.Width = W: shp.Height = H
        End If

        With shp
            .Fill.Visible = msoTrue
            .Fill.ForeColor.RGB = RGB(255, 255, 255)
            .Fill.Transparency = 1
            .Line.Visible = msoFalse
            With .ActionSettings(ppMouseClick)
                .Action = ppActionRunMacro
                .Run = "PPTMark_HandleClick" ' 図形のアクション設定でマクロ実行 [3](https://www.rdpslides.com/pptfaq/FAQ00141_Determine_which_shape_was_clicked.htm)
            End With
            .ZOrder msoBringToFront
        End With
    Next
End Sub

'=========================
' クリック → 座標変換 → 各モード処理
'=========================
Public Sub PPTMark_HandleClick(oSh As Shape)
    If ActivePresentation.SlideShowWindow Is Nothing Then Exit Sub
    Dim ssw As SlideShowWindow
    Set ssw = ActivePresentation.SlideShowWindow ' SlideShowWindow/SlideShowViewの公式API [1](https://learn.microsoft.com/en-us/office/vba/api/powerpoint.slideshowwindow)[2](https://learn.microsoft.com/en-us/office/vba/api/powerpoint.slideshowwindow.view)

    Dim x As Single, y As Single
    If Not ScreenToSlideXY(ssw, x, y) Then Exit Sub ' スライド外（黒帯など）は無視

    Select Case gMode
        Case ModeStamp
            PlaceStamp ssw.View.Slide, x, y
            BringCatcherFront ssw.View.Slide
        Case ModeLine
            DrawLineStep ssw.View.Slide, x, y
            BringCatcherFront ssw.View.Slide
        Case ModeErase
            EraseTopMostAt ssw.View.Slide, x, y
            BringCatcherFront ssw.View.Slide
    End Select
End Sub

'=========================
' 画面座標 → スライド座標（ポイント）
' (DPIからポイント換算し、黒帯補正）[5](https://stackoverflow.com/questions/14635383/ms-powerpoint-how-to-convert-a-shapes-position-and-size-into-screen-coordinate)
'=========================
Private Function ScreenToSlideXY(ByVal ssw As SlideShowWindow, _
                                 ByRef slideX As Single, ByRef slideY As Single) As Boolean
    Dim pt As POINTAPI: GetCursorPos pt

    ' DPI取得
#If VBA7 Then
    Dim hdcPtr As LongPtr, dpiX As Double, dpiY As Double
    hdcPtr = GetDC(0)
    dpiX = GetDeviceCaps(hdcPtr, LOGPIXELSX)
    dpiY = GetDeviceCaps(hdcPtr, LOGPIXELSY)
    ReleaseDC 0, hdcPtr
#Else
    Dim hdc&, dpiX As Double, dpiY As Double
    hdc = GetDC(0)
    dpiX = GetDeviceCaps(hdc, LOGPIXELSX)
    dpiY = GetDeviceCaps(hdc, LOGPIXELSY)
    ReleaseDC 0, hdc
#End If

    ' ウィンドウ位置/サイズ（ポイント→ピクセル）
    Dim winLeftPx As Double, winTopPx As Double, winWpx As Double, winHpx As Double
    winLeftPx = ssw.Left * dpiX / 72
    winTopPx = ssw.Top * dpiY / 72
    winWpx = ssw.Width * dpiX / 72
    winHpx = ssw.Height * dpiY / 72

    ' スライドの実サイズ
    Dim slideWpt As Double, slideHpt As Double, aspect As Double
    slideWpt = ActivePresentation.PageSetup.SlideWidth
    slideHpt = ActivePresentation.PageSetup.SlideHeight
    aspect = slideWpt / slideHpt

    ' 表示領域（黒帯補正）
    Dim dispWpx As Double, dispHpx As Double, offL As Double, offT As Double
    If (winWpx / winHpx) > aspect Then
        dispHpx = winHpx
        dispWpx = dispHpx * aspect
        offL = (winWpx - dispWpx) / 2
        offT = 0
    Else
        dispWpx = winWpx
        dispHpx = dispWpx / aspect
        offL = 0
        offT = (winHpx - dispHpx) / 2
    End If

    Dim mx As Double, my As Double
    mx = pt.x - winLeftPx - offL
    my = pt.y - winTopPx - offT

    If mx < 0 Or my < 0 Or mx > dispWpx Or my > dispHpx Then
        ScreenToSlideXY = False: Exit Function
    End If

    slideX = mx * (slideWpt / dispWpx)
    slideY = my * (slideHpt / dispHpx)
    ScreenToSlideXY = True
End Function

'=========================
' スタンプ配置（サイズ・色・形）
'=========================
Private Sub PlaceStamp(ByVal sld As Slide, ByVal x As Single, ByVal y As Single)
    Dim shp As Shape

    Select Case gStamp
        Case StampStar ' ★はテキストで
            Set shp = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y, 10, 10)
            With shp
                .TextFrame.AutoSize = ppAutoSizeShapeToFitText
                With .TextFrame.TextRange
                    .Text = "★"
                    With .Font
                        .Name = "MS UI Gothic"
                        .size = gSizePt
                        .Bold = msoTrue
                        .Color.RGB = gColor
                    End With
                End With
                .Line.Visible = msoFalse
                .Fill.Visible = msoFalse
                .Left = x - .Width / 2
                .Top = y - .Height / 2
            End With

        Case StampCircle, StampSquare, StampTriangle
            Dim size As Single: size = gSizePt ' そのままptを辺（または直径）に
            Dim leftPos As Single: leftPos = x - size / 2
            Dim topPos As Single:  topPos = y - size / 2

            Select Case gStamp
                Case StampCircle:   Set shp = sld.Shapes.AddShape(msoShapeOval, leftPos, topPos, size, size)
                Case StampSquare:   Set shp = sld.Shapes.AddShape(msoShapeRectangle, leftPos, topPos, size, size)
                Case StampTriangle: Set shp = sld.Shapes.AddShape(msoShapeIsoscelesTriangle, leftPos, topPos, size, size)
            End Select

            With shp
                .Fill.Visible = msoTrue
                .Fill.ForeColor.RGB = gColor
                .Line.ForeColor.RGB = RGB(0, 0, 0)
                .Line.Weight = 0.75
            End With

        Case StampCross ' ×は2本線
            Dim half As Single: half = gSizePt / 2
            Dim l1 As Shape, l2 As Shape
            Set l1 = sld.Shapes.AddLine(x - half, y - half, x + half, y + half)
            Set l2 = sld.Shapes.AddLine(x - half, y + half, x + half, y - half)
            l1.Line.Weight = 2: l1.Line.ForeColor.RGB = gColor
            l2.Line.Weight = 2: l2.Line.ForeColor.RGB = gColor
            Dim grp As ShapeRange
            Set grp = sld.Shapes.Range(Array(l1.Name, l2.Name)).Group
            Set shp = grp(1)
    End Select

    shp.Name = TAG_STAMP & Format(Timer, "0.0000")
    shp.ZOrder msoBringToFront
End Sub

'=========================
' 線を引く（連続）
'=========================
Private Sub DrawLineStep(ByVal sld As Slide, ByVal x As Single, ByVal y As Single)
    Const W As Single = 2.25 ' 太さ固定
    If Not gHasPrev Then
        gPrevX = x: gPrevY = y: gHasPrev = True
        Exit Sub
    End If

    Dim ln As Shape
    Set ln = sld.Shapes.AddLine(gPrevX, gPrevY, x, y)
    With ln.Line
        .Weight = W
        .ForeColor.RGB = gColor
    End With
    ln.Name = TAG_LINE & Format(Timer, "0.0000")
    ln.ZOrder msoBringToFront

    gPrevX = x: gPrevY = y
End Sub

'=========================
' 消しゴム（最前面の本ツール図形を削除）
'=========================
Private Sub EraseTopMostAt(ByVal sld As Slide, ByVal x As Single, ByVal y As Single)
    Dim i As Long, zTop As Long: zTop = -1
    Dim target As Shape: Set target = Nothing

    For i = 1 To sld.Shapes.Count
        Dim shp As Shape: Set shp = sld.Shapes(i)
        If shp.Name <> CLICK_CATCHER_NAME Then
            If (Left$(shp.Name, Len(TAG_STAMP)) = TAG_STAMP) Or _
               (Left$(shp.Name, Len(TAG_LINE)) = TAG_LINE) Then

                If HitInBounding(shp, x, y) Then
                    If shp.ZOrderPosition > zTop Then
                        zTop = shp.ZOrderPosition
                        Set target = shp
                    End If
                End If
            End If
        End If
    Next i

    If Not target Is Nothing Then target.Delete
End Sub

Private Function HitInBounding(ByVal shp As Shape, ByVal x As Single, ByVal y As Single) As Boolean
    HitInBounding = (x >= shp.Left) And (x <= shp.Left + shp.Width) And _
                    (y >= shp.Top) And (y <= shp.Top + shp.Height)
End Function

Private Sub BringCatcherFront(ByVal sld As Slide)
    On Error Resume Next
    sld.Shapes(CLICK_CATCHER_NAME).ZOrder msoBringToFront
    On Error GoTo 0
End Sub

'=========================
' パネルからの変更
'=========================
Public Sub SetMode(ByVal m As MarkMode)
    gMode = m
    If m <> ModeLine Then gHasPrev = False
    If IsFormLoaded("frmPanel") Then frmPanel.UpdateModeLabel
End Sub

Public Sub SetShapeFromIndex(ByVal idx As Long)
    gStamp = idx
    If IsFormLoaded("frmPanel") Then frmPanel.UpdateModeLabel
End Sub

Public Sub SetSizeFromIndex(ByVal idx As Long)
    Dim sizes: sizes = Array(16, 20, 24, 28, 36, 48)
    gSizePt = sizes(idx)
    If IsFormLoaded("frmPanel") Then frmPanel.UpdateModeLabel
End Sub

Public Sub SetColorFromIndex(ByVal idx As Long)
    Dim c As Long
    Select Case idx
        Case 0: c = RGB(255, 0, 0)     ' 赤
        Case 1: c = RGB(0, 0, 255)     ' 青
        Case 2: c = RGB(255, 255, 0)   ' 黄
        Case 3: c = RGB(0, 255, 0)     ' 緑
        Case 4: c = RGB(0, 255, 255)   ' 水
        Case 5: c = RGB(255, 0, 255)   ' 紫
        Case 6: c = RGB(0, 0, 0)       ' 黒
    End Select
    gColor = c
    If IsFormLoaded("frmPanel") Then frmPanel.UpdateModeLabel
End Sub

Private Function IsFormLoaded(ByVal formName As String) As Boolean
    Dim frm As Object
    For Each frm In VBA.UserForms
        If StrComp(VBA.TypeName(frm), formName, vbTextCompare) = 0 Then
            IsFormLoaded = True: Exit Function
        End If
    Next
    IsFormLoaded = False
End Function

' 終了用
Public Sub PPTMark_End()
    On Error Resume Next
    Unload frmPanel
    SlideShowWindows(1).View.Exit
    On Error GoTo 0
End Sub
