' ============================================================
' PowerPoint ロゴ貼り付けマクロ【重複チェック版】
' 機能：
'   1ページ目の画像（ロゴ）を、2ページ目以降の全スライドに
'   1ページ目と全く同じ位置・サイズで貼り付ける
'   ※ 既に同じ位置にロゴがある場合はスキップ
' ============================================================
' 【使い方】
'   1. PowerPoint を開く
'   2. Alt + F11 で VBA エディタを開く
'   3. 既存のコードを全て削除して、このコードを貼り付ける
'   4. Alt + F11 で PowerPoint に戻る
'   5. Alt + F8 で「CopyLogoToAllSlides」を選択して「実行」
' ============================================================

Sub P1のロゴをコピーする()

    Dim oPres As Presentation
    Dim oFirstSlide As Slide
    Dim oTargetSlide As Slide
    Dim oShape As Shape
    Dim oLogo As Shape
    Dim oCopied As Shape
    Dim logoCount As Integer
    Dim i As Integer

    Set oPres = ActivePresentation

    ' スライドが2枚以上あるか確認
    If oPres.Slides.Count < 2 Then
        MsgBox "スライドが2枚以上必要です。", vbExclamation
        Exit Sub
    End If

    Set oFirstSlide = oPres.Slides(1)

    ' 1ページ目の画像を全て収集
    Dim logos(100) As Shape
    logoCount = 0

    For Each oShape In oFirstSlide.Shapes
        If IsImageShape(oShape) Then
            logoCount = logoCount + 1
            Set logos(logoCount) = oShape
        End If
    Next oShape

    ' 1ページ目に画像がなければ終了
    If logoCount = 0 Then
        MsgBox "1ページ目に画像が見つかりませんでした。", vbExclamation
        Exit Sub
    End If

    ' 2ページ目以降の各スライドにロゴをコピー
    Dim pastedSlides As Integer
    Dim skippedSlides As Integer
    pastedSlides = 0
    skippedSlides = 0

    For i = 2 To oPres.Slides.Count
        Set oTargetSlide = oPres.Slides(i)

        Dim j As Integer
        For j = 1 To logoCount
            Set oLogo = logos(j)

            ' 既に同じ位置・サイズのロゴがあればスキップ
            If LogoAlreadyExists(oTargetSlide, oLogo) Then
                skippedSlides = skippedSlides + 1
            Else
                ' コピー＆ペースト
                oLogo.Copy
                oTargetSlide.Shapes.Paste

                ' ペーストした図形を取得（最後に追加されたもの）
                Set oCopied = oTargetSlide.Shapes(oTargetSlide.Shapes.Count)

                ' 1ページ目と同じ位置・サイズに設定
                oCopied.Left = oLogo.Left
                oCopied.Top = oLogo.Top
                oCopied.Width = oLogo.Width
                oCopied.Height = oLogo.Height

                ' 最前面に配置
                oCopied.ZOrder msoBringToFront

                pastedSlides = pastedSlides + 1
            End If
        Next j
    Next i

    ' 結果メッセージ
    Dim msg As String
    If pastedSlides = 0 And skippedSlides > 0 Then
        msg = "全スライドに既にロゴがあるため、何もしませんでした。"
    ElseIf pastedSlides > 0 And skippedSlides > 0 Then
        msg = pastedSlides & " 枚のスライドにロゴを貼り付けました。" & vbCrLf & _
              skippedSlides & " 枚は既にロゴがあったためスキップしました。"
    Else
        msg = pastedSlides & " 枚のスライドにロゴを貼り付けました！"
    End If
    MsgBox msg, vbInformation

End Sub

' ロゴが既に存在するか確認する関数
' 位置（Left/Top）とサイズ（Width/Height）が一致する画像があればTrue
Function LogoAlreadyExists(oSlide As Slide, oLogo As Shape) As Boolean
    Dim oShape As Shape
    Dim tolerance As Single
    tolerance = 1#    ' 1ポイント以内の誤差は同じとみなす

    LogoAlreadyExists = False
    For Each oShape In oSlide.Shapes
        If IsImageShape(oShape) Then
            If Abs(oShape.Left - oLogo.Left) <= tolerance And _
               Abs(oShape.Top - oLogo.Top) <= tolerance And _
               Abs(oShape.Width - oLogo.Width) <= tolerance And _
               Abs(oShape.Height - oLogo.Height) <= tolerance Then
                LogoAlreadyExists = True
                Exit Function
            End If
        End If
    Next oShape
End Function

' 画像かどうかを判定する関数
Function IsImageShape(oShape As Shape) As Boolean
    IsImageShape = False
    If oShape.Type = msoPicture Then
        IsImageShape = True
    ElseIf oShape.Type = msoLinkedPicture Then
        IsImageShape = True
    End If
End Function