'-----------------------------------------------------------------
' 画像で出力（全ページ・表示中ページ）
' ファイル名: パワポ名+通し番号_セクション名+セクション内通し番号.png
' 例: 画像調整マクロ001_ロゴ001.png
'-----------------------------------------------------------------

Sub 画像で出力_全ページ()

    Dim prs          As Presentation
    Dim sld          As Slide
    Dim exportFolder As String
    Dim prsTitle     As String
    Dim sectionName  As String
    Dim fileName     As String
    Dim slideIndex   As Long
    Dim totalSlides  As Long
    Dim padLen       As Integer
    Dim i            As Long

    Set prs = ActivePresentation

    If prs.Path = "" Then
        MsgBox "先にファイルを保存してください。", vbExclamation
        Exit Sub
    End If

    prsTitle     = CleanFN(Left(prs.Name, InStrRev(prs.Name, ".") - 1))
    exportFolder = prs.Path & "\" & prsTitle
    If Dir(exportFolder, vbDirectory) = "" Then MkDir exportFolder

    totalSlides = prs.Slides.Count

    ' 非表示除く枚数でゼロ埋め桁数
    Dim visibleCount As Long
    For i = 1 To totalSlides
        If prs.Slides(i).SlideShowTransition.Hidden <> msoTrue Then
            visibleCount = visibleCount + 1
        End If
    Next i

    Select Case visibleCount
        Case 1 To 9:    padLen = 1
        Case 10 To 99:  padLen = 2
        Case Else:      padLen = 3
    End Select

    ' セクションマップ取得
    Dim slideSection() As String
    ReDim slideSection(1 To totalSlides)
    Call GetSectionMap(prs, slideSection, totalSlides)

    ' エクスポート
    Dim exported As Long                        ' 全体通し番号
    Dim secCounters() As Long                   ' セクション内通し番号管理
    ReDim secCounters(1 To totalSlides)         ' キーとしてslideIndexは使わず名前で管理

    ' セクション名→カウンタの辞書代わりに並列配列を使う
    Dim secNames(100)   As String
    Dim secCounts(100)  As Long
    Dim secNameCnt      As Long
    secNameCnt = 0

    For slideIndex = 1 To totalSlides
        Set sld = prs.Slides(slideIndex)
        If sld.SlideShowTransition.Hidden = msoTrue Then GoTo NextSlide
        sectionName = slideSection(slideIndex)
        exported = exported + 1

        ' セクション内カウンタを更新
        Dim secIdx As Long
        secIdx = 0
        Dim k As Long
        For k = 1 To secNameCnt
            If secNames(k) = sectionName Then
                secIdx = k
                Exit For
            End If
        Next k
        If secIdx = 0 Then
            secNameCnt = secNameCnt + 1
            secIdx = secNameCnt
            secNames(secIdx) = sectionName
            secCounts(secIdx) = 0
        End If
        secCounts(secIdx) = secCounts(secIdx) + 1

        If sectionName = "" Then
            fileName = prsTitle & ZPad(exported, padLen) & ".png"
        Else
            fileName = prsTitle & ZPad(exported, padLen) & "_" & sectionName & ZPad(secCounts(secIdx), padLen) & ".png"
        End If

        sld.Export exportFolder & "\" & fileName, "PNG"
NextSlide:
    Next slideIndex

    MsgBox exported & " 枚出力しました。" & vbCrLf & exportFolder, vbInformation, "完了"

End Sub

'-----------------------------------------------------------------

Sub 画像で出力_表示中()

    Dim prs          As Presentation
    Dim sld          As Slide
    Dim exportFolder As String
    Dim prsTitle     As String
    Dim sectionName  As String
    Dim fileName     As String

    Set prs = ActivePresentation
    Set sld = ActiveWindow.View.Slide

    If prs.Path = "" Then
        MsgBox "先にファイルを保存してください。", vbExclamation
        Exit Sub
    End If

    prsTitle     = CleanFN(Left(prs.Name, InStrRev(prs.Name, ".") - 1))
    exportFolder = prs.Path & "\" & prsTitle
    If Dir(exportFolder, vbDirectory) = "" Then MkDir exportFolder

    Dim totalSlides As Long
    totalSlides = prs.Slides.Count
    Dim slideSection() As String
    ReDim slideSection(1 To totalSlides)
    Call GetSectionMap(prs, slideSection, totalSlides)

    sectionName = slideSection(sld.SlideIndex)

    ' 全体通し番号（非表示除く）
    Dim exported As Long
    Dim i As Long
    For i = 1 To sld.SlideIndex
        If prs.Slides(i).SlideShowTransition.Hidden <> msoTrue Then
            exported = exported + 1
        End If
    Next i

    ' セクション内通し番号
    Dim secCount As Long
    secCount = 0
    For i = 1 To sld.SlideIndex
        If prs.Slides(i).SlideShowTransition.Hidden <> msoTrue Then
            If slideSection(i) = sectionName Then
                secCount = secCount + 1
            End If
        End If
    Next i

    ' ゼロ埋め桁数
    Dim visibleCount As Long
    For i = 1 To totalSlides
        If prs.Slides(i).SlideShowTransition.Hidden <> msoTrue Then
            visibleCount = visibleCount + 1
        End If
    Next i
    Dim padLen As Integer
    Select Case visibleCount
        Case 1 To 9:    padLen = 1
        Case 10 To 99:  padLen = 2
        Case Else:      padLen = 3
    End Select

    If sectionName = "" Then
        fileName = prsTitle & ZPad(exported, padLen) & ".png"
    Else
        fileName = prsTitle & ZPad(exported, padLen) & "_" & sectionName & ZPad(secCount, padLen) & ".png"
    End If

    sld.Export exportFolder & "\" & fileName, "PNG"

    MsgBox "出力しました。" & vbCrLf & exportFolder & "\" & fileName, vbInformation, "完了"

End Sub

'-----------------------------------------------------------------
' 共通：セクションマップをPowerShell経由で取得
'-----------------------------------------------------------------

Private Sub GetSectionMap(prs As Presentation, slideSection() As String, totalSlides As Long)

    Dim i As Long
    For i = 1 To totalSlides
        slideSection(i) = ""
    Next i

    Dim psFile  As String
    Dim mapFile As String
    psFile  = Environ("TEMP") & "\pptx_sec.ps1"
    mapFile = Environ("TEMP") & "\pptx_secmap.txt"

    If Dir(psFile)  <> "" Then Kill psFile
    If Dir(mapFile) <> "" Then Kill mapFile

    Dim fn As Integer
    fn = FreeFile
    Open psFile For Output As #fn
    Print #fn, "Add-Type -AssemblyName System.IO.Compression.FileSystem"
    Print #fn, "$pptxPath = '" & Replace(prs.FullName, "'", "''") & "'"
    Print #fn, "$mapFile  = '" & Replace(mapFile, "'", "''") & "'"
    Print #fn, "$zip = [System.IO.Compression.ZipFile]::OpenRead($pptxPath)"
    Print #fn, "$e   = $zip.Entries | Where-Object { $_.FullName -eq 'ppt/presentation.xml' }"
    Print #fn, "$sr  = [System.IO.StreamReader]::new($e.Open())"
    Print #fn, "$x   = $sr.ReadToEnd()"
    Print #fn, "$sr.Close()"
    Print #fn, "$zip.Dispose()"
    Print #fn, "$sldIds = [regex]::Matches($x, '<p:sldId [^>]*\bid=""(\d+)""') | ForEach-Object { $_.Groups[1].Value }"
    Print #fn, "$idxMap = @{}"
    Print #fn, "for ($n = 0; $n -lt $sldIds.Count; $n++) { $idxMap[$sldIds[$n]] = $n + 1 }"
    Print #fn, "$result = @{}"
    Print #fn, "$secPattern = '(?s)<[\w:]*section\s[^>]*\bname=""([^""]+)""[^>]*>(.*?)</[\w:]*section>'"
    Print #fn, "[regex]::Matches($x, $secPattern) | ForEach-Object {"
    Print #fn, "    $nm = $_.Groups[1].Value"
    Print #fn, "    $body = $_.Groups[2].Value"
    Print #fn, "    [regex]::Matches($body, 'sldId\s[^>]*\bid=""(\d+)""') | ForEach-Object {"
    Print #fn, "        $id = $_.Groups[1].Value"
    Print #fn, "        if ($idxMap.ContainsKey($id)) { $result[$idxMap[$id]] = $nm }"
    Print #fn, "    }"
    Print #fn, "}"
    Print #fn, "$sjis = [System.Text.Encoding]::GetEncoding(932)"
    Print #fn, "$out  = $result.GetEnumerator() | Sort-Object Key | ForEach-Object { ""$($_.Key),$($_.Value)"" }"
    Print #fn, "[System.IO.File]::WriteAllLines($mapFile, $out, $sjis)"
    Close #fn

    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")
    wsh.Run "powershell -NoProfile -NonInteractive -ExecutionPolicy Bypass -File """ & psFile & """", 0, True

    If Dir(mapFile) = "" Then GoTo Cleanup

    fn = FreeFile
    Dim line As String
    Open mapFile For Input As #fn
    Do While Not EOF(fn)
        Line Input #fn, line
        line = Trim(line)
        If InStr(line, ",") > 0 Then
            Dim idx As Long
            idx = CLng(Left(line, InStr(line, ",") - 1))
            Dim nm As String
            nm = Mid(line, InStr(line, ",") + 1)
            If idx >= 1 And idx <= totalSlides Then
                Dim cleaned As String
                cleaned = CleanFN(nm)
                If cleaned = "タイトルなしのセクション" Or cleaned = "既定のセクション" Then
                    cleaned = ""
                End If
                slideSection(idx) = cleaned
            End If
        End If
    Loop
    Close #fn
    Kill mapFile

Cleanup:
    On Error Resume Next
    Kill psFile
    On Error GoTo 0

End Sub

'-----------------------------------------------------------------
' 共通ヘルパー
'-----------------------------------------------------------------

Private Function ZPad(num As Long, digits As Integer) As String
    ZPad = Right(String(digits, "0") & CStr(num), digits)
End Function

Private Function CleanFN(s As String) As String
    Dim r As String: r = s
    Dim c As Variant
    For Each c In Array("\", "/", ":", "*", "?", """", "<", ">", "|")
        r = Replace(r, c, "")
    Next c
    CleanFN = Trim(r)
End Function