1

私はもともと PPT から作成された PDF ファイルを持っています (これにはアクセスできません)。PDFの各ページからタイトル/見出しを単一のドキュメントに抽出する必要があります（形式は関係ありません。Excel、メモ帳、Wordなど、何でも構いません）。ファイルが大きいため、手動で行うことはできず、同様のファイルに対して再度行う必要があります。

PDF を PPT 形式に変換すると役立つと結論付け、PowerPoint VBA でサブルーチンを作成しようとしています。以下のコードを見て、これを達成するために何を変更できるか提案してください。別のアイデアも歓迎します。

注意: PPT に変換し直すと、各スライドのタイトルは PowerPoint の「タイトル」プレースホルダーにはなくなります。それらは単なる通常のテキストボックスです。私はVBAが初めてで、グーグルでコードをコンパイルしました。

出力: これは、スライド番号のリストを含むメモ帳ファイルを印刷します。スライドごとに、スライド内のテキストボックスの数だけ、それぞれのスライド番号を出力します。例: スライド 1 には 3 つのテキスト ボックスがあるため、メモ帳には次のように表示されます。

"スライド: 1

スライド: 1

スライド: 1

スライド: 2

スライド: 2

スライド: 2

スライド: 2

スライド: 2

スライド: 2

スライド: 2"

問題: テキストボックスからテキストを印刷していません。実際には、一番上のテキストボックス (スライドの最初または一番上に配置されている) からのテキストのみが必要です。

コード：

Sub GatherTitles()

On Error GoTo ErrorHandler

Dim oSlide As Slide
Dim strTitles As String
Dim strFilename As String
Dim intFileNum As Integer
Dim PathSep As String
Dim Shp As Shape

If ActivePresentation.Path = "" Then
    MsgBox "Please save the presentation then try again"
    Exit Sub
End If

#If Mac Then
    PathSep = ":"
#Else
    PathSep = "\"
#End If

On Error Resume Next  ' in case there's no title placeholder on the slide
For Each oSlide In ActiveWindow.Presentation.Slides

    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox

    strTitles = strTitles _
        & "Slide: " _
        & CStr(oSlide.SlideIndex) & vbCrLf _
        & oSlide.Shapes(1).TextFrame.TextRange.Text _
        & vbCrLf & vbCrLf

        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select

    Next Shp
Next oSlide
On Error GoTo ErrorHandler

intFileNum = FreeFile

' PC-Centricity Alert!
' This assumes that the file has a .PPT extension and strips it off to make the text file name.
strFilename = ActivePresentation.Path _
    & PathSep _
    & Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
    & "_Titles.TXT"

Open strFilename For Output As intFileNum
Print #intFileNum, strTitles

NormalExit:
Close intFileNum
Exit Sub

ErrorHandler:
MsgBox Err.Description
Resume NormalExit

End Sub
4

3 に答える 3

0

（OPに代わって投稿。）

問題は解決しました。他の誰かが VBA PowerPoint を起動した場合に備えて、参照用の最終的なコード:

Sub GatherTitles()

On Error GoTo ErrorHandler

Dim oSlide As Slide
Dim strTitles As String
Dim strFilename As String
Dim intFileNum As Integer
Dim PathSep As String
Dim Shp As Shape
Dim Count As Integer
Dim Mn As Double

If ActivePresentation.Path = "" Then
    MsgBox "Please save the presentation then try again"
    Exit Sub
End If

#If Mac Then
    PathSep = ":"
#Else
    PathSep = "\"
#End If

On Error Resume Next  ' in case there's no title placeholder on the slide
For Each oSlide In ActiveWindow.Presentation.Slides
Count = 0

    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
Count = Count + 1
        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select
    Next Shp
Count = Count - 1
Dim distmat() As Double
ReDim distmat(0 To Count)
Dim i As Integer
i = 0
    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
distmat(i) = Shp.Top
i = i + 1
        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select
    Next Shp
Mn = distmat(0)
i = i - 1
For j = 1 To i
If distmat(j) < Mn Then
Mn = distmat(j)
End If
Next j

'Next oSlide

'For Each oSlide In ActiveWindow.Presentation.Slides
    For Each Shp In oSlide.Shapes
      Select Case Shp.Type
        Case MsoShapeType.msoTextBox
 If Shp.Top = Mn Then
    strTitles = strTitles _
        & "Slide: " _
        & CStr(oSlide.SlideIndex) & vbCrLf _
        & oSlide.Shapes(1).TextFrame.TextRange.Text _
        & Shp.TextFrame.TextRange.Text & vbCrLf _
        & vbCrLf & vbCrLf
Else
Debug.Print Sld.Name, Shp.Name, "This is not the topmost textbox"
End If

        Case Else
          Debug.Print Sld.Name, Shp.Name, "This is not a text box"
      End Select

    Next Shp
Next oSlide
On Error GoTo ErrorHandler

intFileNum = FreeFile

' PC-Centricity Alert!
' This assumes that the file has a .PPT extension and strips it off to make the text file name.
strFilename = ActivePresentation.Path _
    & PathSep _
    & Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _
    & "_Titles.TXT"

Open strFilename For Output As intFileNum
Print #intFileNum, strTitles

NormalExit:
Close intFileNum
Exit Sub

ErrorHandler:
MsgBox Err.Description
Resume NormalExit

End Sub
于 2015-07-20T12:30:43.623 に答える
0

テキスト ボックスがプレースホルダーでない場合、唯一の方法は、スライド上の各図形の位置を確認することです。以下に応じて X と Y を設定します。

Sub GetTitles()
Dim oSld as Slide
Dim oShp as Shape
Dim myText as String
For Each oSld in ActivePresentation.Slides
For Each oShp in oSld.Shapes
If oShp.Left=X and oShp.Top=Y Then
my Text=oShp.TextFrame.TextRange.Text
Debug.Print myText
End If
Next
Next
End Sub
于 2015-07-19T13:46:59.427 に答える