Sub パワーポイントのタイトル一覧取得()
Dim appPPT As Object
Dim objPPTPres As Object
Dim objPPTSlide As Object
Dim strPPTTitle As String
Dim intRowCount As Integer
Dim intPPTPageNum As Integer
' PowerPointが起動しているかチェックします。
On Error Resume Next
Set appPPT = GetObject(, "PowerPoint.Application")
On Error GoTo 0
' PowerPointが起動していない場合メッセージを表示します。
If appPPT Is Nothing Then
MsgBox "PowerPointが起動していません。"
Exit Sub
End If
' アクティブなプレゼンテーションを取得します。
Set objPPTPres = appPPT.ActivePresentation
' タイトルを取得してExcelに出力します。
If Not objPPTPres Is Nothing Then
' 出力するExcelの行番号を指定します。
intRowCount = 1
'Excelの1シート目を対象にします。
With ThisWorkbook.Sheets(1)
'A,B列の値をクリアします。
.Range("A:B").Clear
' タイトルを出力します。
For Each objPPTSlide In objPPTPres.Slides
strPPTTitle = objPPTSlide.Shapes.Title.TextFrame.TextRange.Text
intPPTPageNum = objPPTSlide.SlideNumber
' タイトルが存在する場合のみ出力します。
If Len(strPPTTitle) > 0 Then
.Cells(intRowCount, 1).Value = strPPTTitle
.Cells(intRowCount, 2).Value = intPPTPageNum
intRowCount = intRowCount + 1
End If
Next objPPTSlide
End With
MsgBox "PowerPointのタイトルを取得し、Excelに出力しました。"
Else
MsgBox "アクティブなプレゼンテーションがありません。"
End If
' PowerPointオブジェクトを解放します。
Set objPPTSlide = Nothing
Set objPPTPres = Nothing
Set appPPT = Nothing
End Sub
If Len(strPPTTitle) > 0 Then
.Cells(intRowCount, 1).Value = strPPTTitle
.Cells(intRowCount, 2).Value = intPPTPageNum
intRowCount = intRowCount + 1
End If
PowerPointオブジェクトを解放します。
Set objPPTSlide = Nothing
Set objPPTPres = Nothing
Set appPPT = Nothing
コメントを残す