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
パワーポイントの目次を生成するVBAコード
パワーポイントの目次を生成するVBAコードになります。
今回の記事のメインの内容となります。
Sub パワーポイントの目次へExcelの文字列を挿入する()
Dim objPPTApp As Object
Dim objPPTPres As Object
Dim objPPTSlide As Object
Dim objPPTShape As Object
Dim strPPTTitle As String
Dim intlastRow As Integer
Dim i As Integer
' PowerPointが起動しているかチェックします。
On Error Resume Next
Set objPPTApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
' PowerPointが起動していない場合メッセージを表示します。
If objPPTApp Is Nothing Then
MsgBox "PowerPointが起動していません。"
Exit Sub
End If
' アクティブなプレゼンテーションを取得します。
Set objPPTPres = objPPTApp.ActivePresentation
'Excelの最初のシートを参照します。
With ThisWorkbook.Sheets(1)
'列の最終行を取得します。
intlastRow = .Cells(Rows.Count, 1).SpecialCells(xlLastCell).Row
'Excelシートの各行に対して処理を行います。
For i = 3 To intlastRow
'目次となる文字列を取得します。
If .Cells(i, 1).Value <> "" Then
If strPPTTitle <> "" Then
'目次2行目以降の文字列を変数に代入します。
strPPTTitle = strPPTTitle & Chr(10) & .Cells(i, 1).Value
Else
'目次1行目の文字列を変数に代入します。
strPPTTitle = .Cells(i, 1).Value
End If
End If
Next i
'本文の処理です。
If strPPTTitle <> "" Then
' パワーポイントの2スライド目を取得します。
Set objPPTSlide = objPPTPres.Slides(2)
'テキストボックスを追加します。
Set objPPTShape = objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 110, 160, 700, 50)
'テキストボックスに文字を追加します。
objPPTShape.TextFrame.TextRange.Text = strPPTTitle
'フォントサイズを変更します。
objPPTShape.TextFrame.TextRange.Font.Size = 24
End If
End With
Set objPPTApp = Nothing
Set objPPTPres = Nothing
Set objPPTSlide = Nothing
Set objPPTShape = Nothing
MsgBox "パワーポイントの2スライド目へ目次を貼り付けました！" & Chr(10) & "OKであれば保存してください。"
End Sub
コメントを残す