エクセルVBAで、フォルダ内のパワポファイル(パスワードなし)を開いて、エクセルにタイトル等を表示

はじめまして。以下は、エクセルVBAにて、ThisWorkbookのあるフォルダとサブフォルダにあるパワポファイルのパスをエクセルに表示させ、エクセルに表示させたパスを使いパワポファイルを開き、エクセルにタイトル等を表示させるコードです。動作を確認しましたが、問題はありませんでした。
ただ、パスワードのあるパワポファイルがフォルダに入っていると、途中で止まってしまいます。パスワードのないパワポファイルは、エクセルにタイトル等表示する必要はありません。そのため、パスワードのないパワポファイルを開かないようにするコードを追記してみましたが、上手くいきません。
どのように追記したらいいか、お分かりになる方がいらっしゃいましたら、教えていただきますでしょうか。又、以下コードはネットの様々なサイトを見て組み合わせて記入したため、不要な部分や追加した方が良い部分があるかもしれません。そちらも、教えて頂けると幸いです。

Sub a()

On Error GoTo ErrHndl

Set e = ThisWorkbook
Set ee = ThisWorkbook.Worksheets("シート1")
Set eee = thisworkbooks.Worksheets("シート2")
Set ppa = CreateObject("PowerPoint.Application") 'パワポつかえるようにする
ppa.Visible = msoTrue 'パワポ表示

ee.Cells.Clear 'エクセルシートクリアー
ee.Range("A3").Value = "パワポファイル名" 'エクセルに見出し表示
ee.Range("B3").Value = "スライド"
ee.Range("C3").Value = "スライドタイトル"
ee.Range("D3").Value = "プレースホルダー"

myPath = ThisWorkbook.Path 'thisworkbookのパスを取得
ReDim FolderLists(0) '動的配列0はフォルダ入れる
FolderLists(0) = myPath

Set FSO = CreateObject("Scripting.FileSystemObject") 'フォルダ操作できるようにする
Set f = FSO.GetFolder(myPath) 'thisworkbookのフォルダー

yy = 1
For Each sf In f.SubFolders 'thisworkbookのフォルダーのサブフォルダーを読み込む
ReDim Preserve FolderLists(yy) '動的配列0を保持しながら
FolderLists(yy) = myPath & "\" & sf.Name 'FolderLists(yy)にサブフォルダ
yy = yy + 1
Next

For Each pt In FolderLists
fn = Dir(pt & "\*.ppt*") 'FolderListsのパワポファイルを取得
Do While fn <> "" 'ファイル名がある間ループ
cnt = cnt + 1
eee.Cells(cnt, 16) = pt & "\" & fn 'エクセルにパワポファイル名表示
fn = Dir() 'Dir初期化
Loop
Next pt
cnt = 0

m = 4 '４行目から
For ii = 1 To eee.Range("P100000").End(xlUp).Row
buf = eee.Cells(ii, 16).Value
ppa.presentations.Open Filename:=buf, ReadOnly:=True 'エクセルに表示されているパワポファイルを読み取り専用でパワポ開く
Set prs = ppa.presentation(buf)
For i = 1 To prs.slides.Count - 1 'スライド最終ページ以外回す
With prs.slides(i)
ee.Cells(m, "B").Value = .slideNumber 'スライドNoをB列へ
With .Shapes
If .HasTitle Then 'タイトルプレースホルダーがあれば
ee.Cells(m, "C").Value = .Title.TextFrame.TextRange.Text 'タイトルをC列へ
End If
With .placeholders
If ee.Cells(m, "B").Value <> 0 Then 'B列がプレースホルダーでなければ（0ページはプレースホルダー不要）
For iii = 1 To .Count 'プレースホルダー回す
If .Item(iii).HasTextFrame Then 'プレースホルダーのテキストフレームあれば
ee.Cells(m, "D").Value = .Item(iii).TextFrame.TextRange.Text 'プレースホルダーをD列へ
End If
Next
End If
End With
End With
End With
If ee.Cells(m, "C").Value = ee.Cells(m, "D").Value Then 'C列とD列一緒だったらD列クリアー
ee.Cells(m, "D").Clear
End If
ee.Cells(m, "A").Value = prs.Path & "\" & prs.Name 'A列ファイル名入れる
m = m + 1
Next i
prs.Close 'パワポクローズ
Next ii
ppa.Quit 'パワポ閉じる
eee.Range("P:P").ClearContents 'P列クリアー
e.Save

GoTo EndTask
ErrHndl:
Select Case Err.Number 'エラートラップ
Case 429
MsgBox "パワポが起動していません"
Case -2147188160
MsgBox "パワポ開かれていません"
Case Else
MsgBox Err.Description & vbCrLf & Err.Number
End Select
Err.Clear
EndTask:
Set ee = Nothing 'オブジェクトクリアー
Set ppp = Nothing
Set ppa = Nothing
Set FSO = Nothing
Set f = Nothing
Set prs = Nothing

End Sub

質問者からの補足コメント

• すみません。本文の内容が間違っておりました。
  正しくは、「パスワードのあるパワポファイルは、エクセルにタイトル等表示する必要はありません。そのため、パスワードのあるパワポファイルを開かないようにするコードを追記してみましたが、上手くいきません。」です。
  以下のURLが参考になりそうです。
  http://officetanaka.net/excel/vba/tips/tips55.htm
  
  質問でお送りしましたppa.presentations.Open Filename:=buf, ReadOnly:=True 'エクセルに表示されているパワポファイルを読み取り専用でパワポ開く　のところあたりで、URLのコードを参考に追記して、パスワードのかかっているパワポファイルを開かないようにすることはできませんでしょうか。因みにActivePresentationというコードは存在しないです。

    補足日時：2017/10/21 15:26

No.5 回答者： WindFaller 回答日時： 2017/10/29 02:02

#4の回答者です。

>分からない部分があったら、また教えて頂けると幸いです。
ぜんぜん、うまく出来ていません。だから期待などしないでくださいね。
元のコードのエラートラップの意味が分かったような気がしました。たぶん、メモリの関係なんだろうと思います。おまけに、PPa.Visible =False でも、エラーが発生するので、どうしようもありませんでした。

No.4 回答者： WindFaller 回答日時： 2017/10/28 02:50

あれこれやってみましたが、分けの分からないエラー自体は、避けられないようです。

そこで、途中からでも始められるようにしました。
ファイルリストを作成したら、Sub ContentsShow() からでも始められるようにし、
Start の所は、ファイル番号(i)を入れれば、その次からでも始められるよにしました。

なお、今回は、PowerPoint を事前バインディング(参照設定しました）
長引かせた割には、大したものができなかったことをお詫び致します。

'Option Explicit
Dim FileLists()　''プロシージャ外変数
Sub ListUPppt()
Dim myPATH As String
myPath = ThisWorkbook.Path &"\"　'末尾に\を入れてください。
Dim FolderLists()
Dim FSO As Object
Dim cnt As Long
Dim k As Long
　Set FSO = CreateObject("Scripting.FileSystemObject")　'フォルダ操作できるようにする
　Set f = FSO.GetFolder(myPATH)　'thisworkbookのフォルダー
　
　　For Each sf In f.SubFolders　'thisworkbookのフォルダーのサブフォルダーを読み込む
　　　ReDim Preserve FolderLists(i)　'動的配列0を保持しながら
　　　FolderLists(i) = myPATH & sf.Name　 'FolderLists(yy)にサブフォルダ
　　　i = i + 1
　　Next
　For Each pt In FolderLists
　If pt = "" Then Exit For
　On Error Resume Next
　fn = Dir(pt & "\*.ppt?")　'FolderListsのパワポファイルを取得
　Do While fn <> ""　'ファイル名がある間ループ
　　ReDim Preserve FileLists(cnt)
　　FileLists(cnt) = pt & "\" & fn
　　fn = Dir()
　　cnt = cnt + 1
　Loop
　On Error GoTo 0
　Next
　k = UBound(FileLists) + 1
　Worksheets("Sheet2").Range("P1").Resize(k).Value = Application.Transpose(FileLists)
　Call ContentsShow
End Sub
'******
Sub ContentsShow()
'中途で始める時には、以下のStart にファイル番号を入れます。
　''FileLists()
　'PP開始
　Dim dummy
　Dim i As Long
　On Error Resume Next
　dummy = UBound(FileLists())
　On Error GoTo 0
　If dummy = 0 Then MsgBox "FileListsが必要です。"
　　With Worksheets("Sheet2")
　　　For i = 1 To .Cells(Rows.Count, "P").End(xlUp).Row
　　　　ReDim Preserve FileLists(i - 1)
　　　　FileLists(i - 1) = .Cells(i, "P").Value
　　　Next
　　End With
　　If i < 2 Then MsgBox "FileLists 作成失敗", vbCritical: Exit Sub
　Dim Ppa As PowerPoint.Application
　Dim PPP As PowerPoint.Presentations
　Dim PPaP As PowerPoint.Presentation
　Dim Prs As PowerPoint.Slides
　Dim eaSlide As PowerPoint.Slide
　Dim Start As Long
　Start = 0　'手動で変更する場合
　Dim sh1 As Worksheet
　Set sh1 = Worksheets("Sheet1")
　With sh1
　m = .Cells(Rows.Count, 1).End(xlUp).Row
　If m < 5 Then
　　.Range("A3").Resize(, 4).Value = Array("パワポファイル名", "スライド", "スライドタイトル", "プレースホルダー")
　　.Range("A3").Resize(, 4).EntireColumn.AutoFit
　　 m = 4　'４行目から
　Else
　　m = m + 1
　End If
　End With
　Set Ppa = New PowerPoint.Application
　　Ppa.Visible = True　'パワポ表示
　　On Error GoTo EndLoop
　　For j = Start To UBound(FileLists)
　　　fn = FileLists(j)
　　　Ppa.DisplayAlerts = ppAlertsNone
　　　Set dummy = Ppa.ProtectedViewWindows.Open(fn, """", msoTrue).Edit
　　　If Not IsObject(dummy) Then GoTo EndLoop
　　　Set PPaP = Ppa.ActivePresentation
　　　PPaP.Close
　　　
　　　Set PPaP = Ppa.Presentations.Open(Filename:=fn, ReadOnly:=msoTrue)　'エクセルに表示されているパワポファイルを読み取り専用でパワポ開く
　　　Ppa.DisplayAlerts = ppAlertsAll
　　　Set PPaP = Ppa.Presentations(fn)
　　　　　For i = 1 To PPaP.Slides.Count - 1　'スライド最終ページ以外回す
　 Set eaSlide = PPaP.Slides(i)
　　With eaSlide
　　　sh1.Cells(m, "B").Value = .SlideNumber　'スライドNoをB列へ
　　　With .Shapes
　　　　If .HasTitle Then　'タイトルプレースホルダーがあれば
　　　　　sh1.Cells(m, "C").Value = .Title.TextFrame.TextRange.Text　'タイトルをC列へ
　　　　　　　　End If
　　　　　　　　With .Placeholders
　　　　If sh1.Cells(m, "B").Value <> 0 Then　'
　　　　　For iii = 1 To .Count　'プレースホルダー回す
　　　　　　If .Item(iii).HasTextFrame Then　'プレースホルダーのテキストフレームあれば
　　　　　　　sh1.Cells(m, "D").Value = .Item(iii).TextFrame.TextRange.Text　'プレースホルダーをD列へ
　　　　　　End If
　　　　　Next
　　　　End If
　　　　End With
　　　 End With
　　 End With
　　If sh1.Cells(m, "C").Value = sh1.Cells(m, "D").Value Then　'C列とD列一緒だったらD列クリアー
　　　sh1.Cells(m, "D").Clear
　　End If
　　sh1.Cells(m, "A").Value = PPaP.Path & "\" & PPaP.Name　'A列ファイル名入れる
　　m = m + 1
　　DoEvents
　　If i > 100 Then
　　　 Sleep 2000 '停止
　　 End If
　Next
　On Error Resume Next
　　PPaP.Close　'パワポクローズ
　 On Error GoTo 0
EndLoop:
　　　　　If Err.Number <> 0 Then
　　　　　 Debug.Print "Err " & i & ", " & fn; Err.Number
　　　　　 Err.Clear
　　　　　End If
　　　　Next
EndTask:
　　　Set PPP = Nothing
　　　Set Ppa = Nothing
End Sub

この回答へのお礼

有難うございます。とても助かります。
来週、試してみます。
分からない部分があったら、また教えて頂けると幸いです。

お礼日時：2017/10/28 21:08

No.3 回答者： WindFaller 回答日時： 2017/10/23 21:26

#2のお礼欄：

わかりました。
>自分の作ったプログラムの中にどう入れ込んだらいいのか分からず苦戦中です。（私はプログラミング初心者のため…）

一応、こちらのマクロの作成自体が、後先になるのかもしれませんが、私も、全編でトライしてみます。元のコードが初心者かどうかよりも、かなり凝った内容ですので、私自身が、ちょうちょしてしまいました。本来、二つぐらいに分散してもよい内容だと思います。

No.2 回答者： WindFaller 回答日時： 2017/10/21 23:04

こんばんは。

最初に、変数の宣言をしていないコードで、PPT のファイルを、たぶんDocumentフォルダー全体から探すというコードから出されてしまうと、読まされる側は、ちょっとしんどいです。

#1さんの仰ることはもっともなのですが、制作上の一般論ですから、聞き流してもよいのですが、コード全体を、On Error でまとめてしまうと、みえるものが見えなくなってしまうのです。最終結果としてなら、もちろん、誰も文句をいう筋ではありません。

ただ、ある程度は、IsObject などで、プログラム的に回避したほうが、VBAマクロは速いのですが、Password 問題だけは、長年やっている有識者に聞くしか目処が立たないと思います。方法があるはずだと信じて、偶然の結果で生まれた産物だからです。

質問に戻りますが、
>パスワードのかかっているパワポファイルを開かないようにすることはできませんでしょうか。

しばらく考えてみました。PPTは、Excelのような、ダミーバスワードを送るOpen　メソッドがありませんので、 Ppa.ProtectedViewWindows.Open(fname, """").Edit　これで、戻り値を取ってみました。Excelでずっとやってきた方法の変形なので、これがよいのか分かりません。試してみてください。私のオリジナルです。

こちらはのPPT 2013のExcel用のサンプルコードです。
適当に加工して試してみてください。
Edit 画面が不都合なら、フラグを立てた後に、閉じて、再度開ければよいわけです。
これで、パスワード・ダイアログボックスを使わないで、パスワード付きファイルが判定できるはずです。

Dim Ppa As PowerPoint.Application　'参照設定で行ってみました。
　Dim dummy As Variant
　Set Ppa = New PowerPoint.Application
　On Error Resume Next　''いらないかもしれません。
　'ファイル名
　fname = "C:\Temp\Test1.pptx"
　Set dummy = Ppa.ProtectedViewWindows.Open(fname, """").Edit
　If Not IsObject(dummy) Then MsgBox "パスワードがあります。", vbExclamation: Exit Sub
　Set PPaP = Ppa.ActivePresentation
　Stop　'ここで様子をみてください。
　PPaP.Close
　On Error GoTo 0

この回答へのお礼

教えて頂き、有難うございます。
オリジナルで作って頂きましたPpa.ProtectedViewWindows.Open(fname, """").Editで上手くいきました。感動です！
ただ、自分の作ったプログラムの中にどう入れ込んだらいいのか分からず苦戦中です。（私はプログラミング初心者のため…）明日も挑戦してみます。
万が一分からなかったら、また教えを乞うかも知れません。その時は、どうぞ宜しくお願い致します。

お礼日時：2017/10/23 20:50

No.1 回答者： k_jinen 回答日時： 2017/10/21 08:56

詳しくは見ていないので違っているかも知れませんが、on error gotoのトラップを全体にかけておられるのが良くないのだと思います。

ファイルopen部分にトラップする箇所を局所化し、resume でループ内の適切なラベル部分に復帰させるようにすれば良いと思います。

ループを無事に抜けたら、トラップをリセットし、次にエラートラップ必要な領域に入る前に、トラップを設定して行くという具合に、細かく制御していけば、途中で止まることは無くなると思います。

この回答へのお礼

ご回答有難うございます。
On Error GoToを全体にかけErr.clearでエラー情報を削除しています。これは、Createobjectでパワポやフォルダを操作できるようにしているのですが、途中エラーで止まってしまうと、OLEオートメーションと出て、エクセルが固まってしまうためです。VBA初心者のため、これすらも間違った考えかもしれませんが・・

パスワード付きのパワポを開かずスキップするには、以下のURLが参考になりそうです。
http://officetanaka.net/excel/vba/tips/tips55.htm
activepresentationというコードが恐らく存在しないため、コードを変えることが必要となります。エラー回避方法も何か良い方法が分かりましたら、教えて頂けると幸いです。

お礼日時：2017/10/21 15:45