Only Open/Save/Close Excel/Word/Powerpoint Files of Multiple Folders At Once (Using Windows DIR Command)
はじめに
今回は一風変わったマクロです。というか、実用性は考慮しておりません。ただ「開いて、保存して、閉じるだけ」のマクロです。
しかし、その割に非常に長いマクロです。「開く、保存する、閉じる」の3つの作業のうち、「開く」に全力を注いでいます。
ただ開くだけなら簡単だろうと思われるでしょうが、そうでもありません。「保存するために」開くにはそれなりの工夫が必要です。
複数のフォルダ（サブフォルダを含む）に入っているファイルの中からエクセル・ワード・パワポのファイルだけを探し出し、開いて保存して閉じるプログラムです。
そのためのテクニックとして、今回は「FileSystemObject」オブジェクトはつかわずに、Windowsの「DIR」コマンドをつかっています。
また、パスワードの領域には立ち入っていませんが、それ以外の考慮すべき問題はすべて考慮しました。
・動作は無保証です。
・パスワードがかかっているファイルが存在すると、エラーでプログラムが止まります。
・動作確認は、Windows 10 + Excel 2016、Windows 7 + Excel 2010でおこなっています。
・ファイルはここからダウンロードしてください。
本マクロのソースコード
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetInputState Lib "user32" () As LongPtr
#Else
Private Declare Function GetInputState Lib "user32" () As Long
#End If
Public Sub S_OnlyOpenSaveCloseFiles_Main()
Dim myStatus As Boolean: myStatus = F_ShowStatusBar
Dim TargetPath As String
TargetPath = F_GetTargetPath
If TargetPath = "" Then Exit Sub
Call S_ShowMessageForWatchingStatusBar
Dim StartingTime As Double: StartingTime = Timer
Switch = True
Dim TargetList() As Variant
TargetList = F_GetTargetList(TargetPath)
If F_IsEmptyArray(TargetList) = True Then Exit Sub
If F_CheckFileAttribute(TargetList) = True Then Exit Sub
If F_IsOpenedFile(TargetList) = True Then Exit Sub
Dim Files As Long
Files = F_OnlyOpenSaveCloseFiles_Core(TargetList)
Switch = False
Call S_HideStatusBar(myStatus)
Dim ElapsedTime As Double: ElapsedTime = Timer - StartingTime
Call S_ShowResulting(Files, ElapsedTime)
End Sub
Private Function F_ShowStatusBar() As Boolean
F_ShowStatusBar = True
With Application.CommandBars("Status Bar")
If .Visible = False Then
F_ShowStatusBar = False
.Visible = True
End If
End With
End Function
Private Function F_GetTargetPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "開いて保存して閉じるだけのファイルのある" & _
"フォルダ（サブフォルダを含む）を指定してください。"
.ButtonName = "フォルダ指定(&S)"
.InitialView = msoFileDialogViewList
.AllowMultiSelect = False
Select Case .Show
Case True
F_GetTargetPath = .SelectedItems(1)
Case False
MsgBox "キャンセルが押されたので終了します。", _
vbExclamation, "フォルダ名取得中"
F_GetTargetPath = ""
Exit Function
End Select
End With
End Function
Private Sub S_ShowMessageForWatchingStatusBar()
MsgBox "プログラム実行中は左下のステータスバーに注目して下さい。" & _
vbCrLf & "パスワード設定の進捗状況が表示されます。", _
vbInformation, "開いて保存して閉じるだけのマクロ"
End Sub
Private Property Let Switch(ByVal Flag As Boolean)
With Application
.ScreenUpdating = Not Flag
.EnableEvents = Not Flag
.DisplayAlerts = Not Flag
.Calculation = _
IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
.PrintCommunication = Not Flag
End With
End Property
Private Function F_GetTargetList(ByVal TargetPath As String) As Variant()
Application.StatusBar = _
"開いて保存して閉じる途中… 進捗状況：ファイル一覧取得中..."
Dim myDir As String: myDir = CurDir()
ChDrive TargetPath: ChDir TargetPath
Dim List As String: List = Environ("TEMP") & "Dir.tmp"
Dim myCmd As String
Const TARGET_EXTENSION As String = "*.xls? *.doc? *.ppt?"
myCmd = "Dir " & TARGET_EXTENSION & " /b/s/a:-d > " & _
"""" & List & """"
On Error Resume Next
With CreateObject("WScript.Shell")
Const ARGUMENT_WINDOW_MINIMIZED As Long = 7
.Run "cmd /c" & myCmd, ARGUMENT_WINDOW_MINIMIZED, True
End With
If Err.Number <> 0 Then
MsgBox "エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description, _
vbCritical, "ファイル一覧取得中"
Exit Function
End If
On Error GoTo 0
ChDrive myDir: ChDir myDir
If FileLen(List) < 1 Then
MsgBox "該当するファイルがありません。", vbExclamation, _
"ファイル一覧取得中"
Exit Function
End If
Dim temp() As Byte
Open List For Binary As #1
ReDim temp(1 To LOF(1))
Get #1, , temp
Close #1
Kill List
Dim FileList() As String
FileList() = Split(StrConv(temp, vbUnicode), vbCrLf)
F_GetTargetList = WorksheetFunction.Transpose(FileList)
End Function
Private Function F_IsEmptyArray(ByRef TargetList() As Variant) _
As Boolean
On Error GoTo HandleError
Application.StatusBar = "開いて保存して閉じる最中… " & _
"進捗状況：ファイル一覧検証中..."
Select Case IsArray(TargetList)
Case True
If UBound(TargetList) >= 0 Then
F_IsEmptyArray = False
Else
F_IsEmptyArray = True
Application.StatusBar = False
MsgBox "配列が空なのでプログラムを終了します。", _
vbExclamation, "空の配列判定中"
End If
Case False
F_IsEmptyArray = True
Application.StatusBar = False
MsgBox "配列が空なのでプログラムを終了します。", _
vbExclamation, "空の配列判定中"
End Select
Exit Function
HandleError:
F_IsEmptyArray = True
Application.StatusBar = False
MsgBox "配列が空なのでプログラムを終了します。", _
vbExclamation, "空の配列判定中"
End Function
Private Function F_CheckFileAttribute _
(ByRef TargetList() As Variant) As Boolean
Application.StatusBar = "開いて保存して閉じる最中… " & _
"進捗状況：ファイル属性確認・変更中..."
Dim Path As Variant
For Each Path In TargetList
If Path <> "" And Path <> ThisWorkbook.FullName _
And Not LCase(Mid(Path, InStrRev(Path, "\") + 1)) Like _
"personal.xls?" Then
Dim myAttribute As VbFileAttribute
myAttribute = GetAttr(Path)
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H4000
myAttribute = myAttribute And Not _
(FILE_ATTRIBUTE_COMPRESSED Or _
FILE_ATTRIBUTE_ENCRYPTED)
If (myAttribute And vbReadOnly) = vbReadOnly Then
myAttribute = (myAttribute And Not vbReadOnly)
End If
On Error Resume Next
SetAttr PathName:=Path, Attributes:=myAttribute
If Err.Number <> 0 Then
If Len(Path) > 50 Then
Path = Left$(Path, InStr(Path, "\")) & _
String(6, ".") & _
Mid$(Path, InStr(Len(Path) - 40, "\"))
End If
MsgBox "ファイルの読み取り専用属性を解除できない" & _
"ものがあるため、処理を終了します。" & _
vbCrLf & _
"ファイル名：" & Path & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description, _
vbCritical, "読み取り専用属性解除不能"
F_CheckFileAttribute = True
Application.StatusBar = False
Exit Function
End If
On Error GoTo 0
End If
Next Path
End Function
Private Function F_IsOpenedFile(ByRef TargetList() As Variant) As Boolean
Dim Path As Variant
For Each Path In TargetList
If Path <> "" And Path <> ThisWorkbook.FullName _
And Not LCase(Mid(Path, InStrRev(Path, "\") + 1)) Like _
"personal.xls?" Then
On Error Resume Next
Open Path For Append As #1
Close #1
If Err.Number <> 0 Then
If Len(Path) > 50 Then
Path = Left$(Path, InStr(Path, "\")) & _
String(6, ".") & _
Mid$(Path, InStr(Len(Path) - 40, "\"))
End If
MsgBox "すでに開いているファイルがあるため、" & _
"処理を終了します。" & vbCrLf & _
"開いているファイルを閉じてから、" & _
"再度プログラムを実行してください。" & _
vbCrLf & "ファイル名：" & Path & _
vbCrLf & "エラー番号：" & Err.Number & _
vbCrLf & "エラー内容：" & Err.Description, _
vbCritical, "開いているファイルの確認中"
F_IsOpenedFile = True
Application.StatusBar = False
Exit Function
End If
On Error GoTo 0
End If
Next Path
End Function
Private Function F_OnlyOpenSaveCloseFiles_Core _
(ByRef TargetList() As Variant) As Long
Application.StatusBar = "開いて保存して閉じる最中… " & _
"進捗状況：" & UBound(TargetList) - 1 & _
"件中 1件目の処理準備中..."
Dim Path As Variant
For Each Path In TargetList
If Path <> "" Then
Dim Extension As String
Extension = LCase(Mid(Path, InStrRev(Path, ".") + 1))
Dim File As Object, cnt As Long
On Error Resume Next
Select Case Extension
Case "xls", "xlsx", "xlsm"
Set File = Workbooks.Open _
(Filename:=Path, UpdateLinks:=False, _
IgnoreReadOnlyRecommended:=True)
If GetInputState() = True Then DoEvents
With File
If .ReadOnly = False Then
If ThisWorkbook.FullName <> .FullName _
And Not LCase(.Name) Like _
"personal.xls?" Then
If .MultiUserEditing = True Then
.ExclusiveAccess
End If
If .CheckCompatibility = True Then
.CheckCompatibility = False
End If
cnt = cnt + 1
Application.StatusBar = _
"開いて保存して閉じる最中… " & _
"進捗状況：" & _
UBound(TargetList) - 1 & _
"件中 " & cnt & "件目処理中 ／ " & _
"処理ファイル名：" & .FullName
Call S_HandleExcelWorkbook(File)
End If
End If
End With
Set File = Nothing
Case "doc", "docx", "docm"
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.DisplayAlerts = wdAlertsNone
.Visible = False
End With
Set File = wdApp.Documents.Open(Filename:=Path)
If GetInputState() = True Then DoEvents
With File
If .ReadOnly = False Then
cnt = cnt + 1
Application.StatusBar = _
"開いて保存して閉じる最中… " & _
"進捗状況：" & _
UBound(TargetList) - 1 & _
"件中 " & cnt & "件目処理中 ／ " & _
"処理ファイル名：" & .FullName
Call S_HandleWordDocument(File)
End If
End With
Set File = Nothing
Case "ppt", "pptx", "pptm"
Dim ppApp As Object
Set ppApp = _
CreateObject("Powerpoint.Application")
ppApp.DisplayAlerts = ppAlertsNone
Set File = ppApp.Presentations.Open _
(Filename:=Path, WithWindow:=msoFalse)
If GetInputState() = True Then DoEvents
With File
If .ReadOnly = msoFalse Then
cnt = cnt + 1
Application.StatusBar = _
"開いて保存して閉じる最中… " & _
"進捗状況：" & _
UBound(TargetList) - 1 & _
"件中 " & cnt & "件目処理中 ／ " & _
"処理ファイル名：" & .FullName
Call S_HandlePowerpointPresentation(File)
End If
End With
Set File = Nothing
End Select
On Error GoTo 0
End If
Next Path
wdApp.Quit
Set wdApp = Nothing
ppApp.Quit
Set ppApp = Nothing
F_OnlyOpenSaveCloseFiles_Core = cnt
Application.StatusBar = False
End Function
Private Sub S_HandleExcelWorkbook(ByVal File As Object)
With File
.Save
.Close
End With
End Sub
Private Sub S_HandleWordDocument(ByVal File As Object)
With File
.Saved = False
.Save
.Close
End With
End Sub
Private Sub S_HandlePowerpointPresentation(ByVal File As Object)
With File
.Save
.Close
End With
End Sub
Private Sub S_HideStatusBar(ByVal myStatus As Boolean)
If myStatus = False Then
Application.CommandBars("Status Bar").Visible = False
End If
End Sub
Private Sub S_ShowResulting(ByVal Files As Long, ByVal ElapsedTime As Double)
MsgBox "開いて保存して閉じるだけの処理終了" & vbCrLf & _
"処理ファイル数は " & Files & " 個です。" & vbCrLf & _
"処理時間は " & Round(ElapsedTime, 2) & " 秒です。", _
vbInformation, "開いて保存して閉じるだけのマクロ"
End Sub
「GetInputState」関数
#If VBA7 Then
Private Declare PtrSafe Function GetInputState Lib "user32" () As LongPtr
#Else
Private Declare Function GetInputState Lib "user32" () As Long
#End If
「GetInputState」関数は、Windwos API関数の1つです。Windows APIは、Windowsの機能をVBAやC#、VB.NETなどのプログラムから使うための関数です。
イベントキューという抽象的な「場所」にイベント、ここでは「ファイルを開く」というイベントが待っていないかどうか調べる関数です。
この関数が必要な理由は後ほど説明します。
メインプロシージャ
Public Sub S_OnlyOpenSaveCloseFiles_Main()
Dim myStatus As Boolean: myStatus = F_ShowStatusBar
Dim TargetPath As String
TargetPath = F_GetTargetPath
If TargetPath = "" Then Exit Sub
Call S_ShowMessageForWatchingStatusBar
Dim StartingTime As Double: StartingTime = Timer
Switch = True
Dim TargetList() As Variant
TargetList = F_GetTargetList(TargetPath)
If F_IsEmptyArray(TargetList) = True Then Exit Sub
If F_CheckFileAttribute(TargetList) = True Then Exit Sub
If F_IsOpenedFile(TargetList) = True Then Exit Sub
Dim Files As Long
Files = F_OnlyOpenSaveCloseFiles_Core(TargetList)
Switch = False
Call S_HideStatusBar(myStatus)
Dim ElapsedTime As Double: ElapsedTime = Timer - StartingTime
Call S_ShowResulting(Files, ElapsedTime)
End Sub
メインプロシージャは非常にシンプルにしました。具体的な処理はすべてサブプロシージャにまかせて、変数の受け渡しに徹しているので、処理の流れを追うことができます。
このとき、分かりやすいプロシージャ名を付けるのが肝心です。
プロシージャ名からサブプロシージャで何をしているのかわかるような名前を付けます。
英語がダメという方は日本語のプロシージャ名でもかまいません。
自分がわかりやすいプロシージャ名を付けるのが重要です。
私は、サブプロシージャ名の頭には、接頭辞として、「S_」を、ファンクションプロシージャ名の頭には、接頭辞として、「F_」を付けています。
これは、かんたんプログラミング Excel2000 VBA 応用編の45ページの記事「サブルーチンのタイトルの付け方」で推奨されていたやり方です。
VBAが有するキーワードは非常に膨大で、見慣れない用語を目にしたときには、それがキーワードなのか、もしくはサブルーチンなのか、時に迷うことがあります。（途中略）サブルーチンのタイトルに若干工夫を凝らすだけで、このように「VBAのキーワードと混同しないステートメント」が記述することを覚えておいてください。
私は、この本を読んでから18年経った今も覚えていて、ちゃんと接頭辞を付けています。
また、大きなプログラムを書くときは、プロシージャの分割が必須になります。分割せずにメインプロシージャにすべて詰め込むと、非常に見づらくなります。
私が実際にこのプログラムを書いたときは、上から順番に1つ命令文を書くと、そのサブプロシージャを書き、出来上がると、次に取り掛かりました。つまり、上から順番に、かつメインプロシージャとサブプロシージャを同時に書いていきました。
プロシージャをどう分割したらいいかわからない、という方には私と同じやり方をおススメします。
「F_ShowStatusBar」ファンクションプロシージャ
Private Function F_ShowStatusBar() As Boolean
F_ShowStatusBar = True
With Application.CommandBars("Status Bar")
If .Visible = False Then
F_ShowStatusBar = False
.Visible = True
End If
End With
End Function
「F_ShowStatusBar」は、ファンクションプロシージャの名前であると同時に、Boolean型の変数でもあります。その変数は、「True」のときにステータスバーを表示している状態を表すようにしています。「False」の場合は非表示の状態です。
最初に「F_ShowStatusBar = True」として、ステータスバーを表示しているものと考え、その上で、ステータスバーが非表示の場合には、変数「F_ShowStatusBar」に「Flase」を格納すると同時にステータスバーを表示しています。
変数「F_ShowStatusBar」に「False」を格納することは、最終的に「S_HideStatusBar」の動作に関わってきます。
「F_GetTargetPath」ファンクションプロシージャ
Private Function F_GetTargetPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "開いて保存して閉じるだけのファイルのある" & _
"フォルダ（サブフォルダを含む）を指定してください。"
.ButtonName = "フォルダ指定(&S)"
.InitialView = msoFileDialogViewList
.AllowMultiSelect = False
Select Case .Show
Case True
F_GetTargetPath = .SelectedItems(1)
Case False
MsgBox "キャンセルが押されたので終了します。", _
vbExclamation, "フォルダ名取得中"
F_GetTargetPath = ""
Exit Function
End Select
End With
End Function
「F_GetTargetPath」ファンクションプロシージャは、開いて保存して閉じる対象（Target）となるファイルの存在するフォルダのパス名、すなわち「TargetPath」を取得（Get）します。
「Application.FileDialog(msoFileDialogFolderPicker)」は、以前にも説明していますが、フォルダを選択するためのダイアログです。
ここでは、「.AllowMultiSelect = False」として、1つのフォルダだけを選択するようにしています。
選択するのは1つのフォルダだけですが、本プログラムで処理するのは、ここで選択したフォルダのサブフォルダを含むすべてのフォルダのすべてのファイルが対象です。
「F_GetTargetPath = .SelectedItems(1)」で選択されたフォルダ名を、変数名でもある「F_GetTargetPath」に格納しています。
「S_ShowMessageForWatchingStatusBar」サブプロシージャ
Private Sub S_ShowMessageForWatchingStatusBar()
MsgBox "プログラム実行中は左下のステータスバーに注目して下さい。" & _
vbCrLf & "パスワード設定の進捗状況が表示されます。", _
vbInformation, "開いて保存して閉じるだけのマクロ"
End Sub
メッセージボックスを表示するだけのサブプロシージャですので、メインプロシージャに書いてもかまいません。
私はメインプロシージャをできるだけシンプルにしたかったので、サブプロシージャの中にMsgBox関数を書きました。
「Switch」プロパティプロシージャ
Private Property Let Switch(ByVal Flag As Boolean)
With Application
.ScreenUpdating = Not Flag
.EnableEvents = Not Flag
.DisplayAlerts = Not Flag
.Calculation = _
IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
.PrintCommunication = Not Flag
End With
End Property
プロパティプロシージャは、主にクラスモジュールで使われ、標準モジュールではめったに使われません。
ですが、標準モジュールでの使い方を紹介したのがこちらのページ。
VBA マクロ高速化のために停止すべき3項目 – t-hom’s diary
ここに書いてあることを多少アレンジして、ほぼ完全コピーしたのが「Switch」プロパティプロシージャです。
目的は、プログラムの高速化・自動化です。
上のページと違うところは、「.DisplayAlerts = Not Flag」と「.PrintCommunication = Not Flag」が入っているところと、プロシージャ名です。
「F_GetTargetList」ファンクションプロシージャ
Private Function F_GetTargetList(ByVal TargetPath As String) As Variant()
Application.StatusBar = _
"開いて保存して閉じる途中… 進捗状況：ファイル一覧取得中..."
Dim myDir As String: myDir = CurDir()
ChDrive TargetPath: ChDir TargetPath
Dim List As String: List = Environ("TEMP") & "Dir.tmp"
Dim myCmd As String
Const TARGET_EXTENSION As String = "*.xls? *.doc? *.ppt?"
myCmd = "Dir " & TARGET_EXTENSION & " /b/s/a:-d > " & _
"""" & List & """"
On Error Resume Next
With CreateObject("WScript.Shell")
Const ARGUMENT_WINDOW_MINIMIZED As Long = 7
.Run "cmd /c" & myCmd, ARGUMENT_WINDOW_MINIMIZED, True
End With
If Err.Number <> 0 Then
MsgBox "エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description, _
vbCritical, "ファイル一覧取得中"
Exit Function
End If
On Error GoTo 0
ChDrive myDir: ChDir myDir
If FileLen(List) < 1 Then
MsgBox "該当するファイルがありません。", vbExclamation, _
"ファイル一覧取得中"
Exit Function
End If
Dim temp() As Byte
Open List For Binary As #1
ReDim temp(1 To LOF(1))
Get #1, , temp
Close #1
Kill List
Dim FileList() As String
FileList() = Split(StrConv(temp, vbUnicode), vbCrLf)
F_GetTargetList = WorksheetFunction.Transpose(FileList)
End Function
Windowsの「DIR」コマンドを使って、ファイル一覧を求める、本プログラムの中でも、重要なプロシージャです。
Application.StatusBar = _
"開いて保存して閉じる途中… 進捗状況：ファイル一覧取得中..."
ステータスバーにメッセージを表示する命令です。進捗状況に応じて、適切なメッセージを表示させることが重要です。メッセージを消去する場合は「Application.StatusBar = False」とします。
Dim myDir As String: myDir = CurDir()
現在のディレクトリ（カレント・ディレクトリ）を変数「myDir」に格納します。これは、後ほど出てくる命令でカレント・ディレクトリを変更してしまうため、元のカレント・ディレクトリに戻すために必要な作業です。
ChDrive TargetPath: ChDir TargetPath
Dim List As String: List = Environ("TEMP") & "Dir.tmp"
上に述べたように、カレント・ディレクトリを変数「TargetPath」に格納しているパスに変更しています。
普通は「Cドライブ」だと思いますが、そうでないレア・ケースにも対応するようにしています。
「ChDrive」は、カレント・ドライブを変更する命令です。引数にパス名などを指定した場合、最初の1文字が表すドライブに変更します。
重要な点は、カレント・ディレクトリを変更したい場合は、先にカレント・ドライブを変更しておく必要がある、という点です。
カレント・ドライブを変更せずにカレント・ディレクトリを変更しても無視されます。
Dim myCmd As String
Const TARGET_EXTENSION As String = "*.xls? *.doc? *.ppt?"
myCmd = "Dir " & TARGET_EXTENSION & " /b/s/a:-d > " & _
"""" & List & """"
変数・定数の宣言と、初期値の代入です。
「myCmd」にはWindowsの「DIR」コマンドの文字列を代入します。
「TARGET_EXTENSION」には検索する拡張子を代入しています。「*.xls?」は拡張子の先頭3文字が「xls」で始まる3文字または4文字の拡張子を持つ、すべてのファイルを表します。つまり、よく使われるエクセルファイルを表します。
同様に「*.doc?」はよく使われるワードファイルを表し、「*.ppt?」はよく使われるパワポファイルを表します。
「myCmd」には「DIR」コマンドの文字列を代入しますが、その解説には次のページがふさわしいと思います。
Windowsのdirコマンドでファイル名の一覧を取得する：Tech TIPS – @IT
また、「””””」の意味がわからない方は、次のページを読むといいでしょう。
Office TANAKA – Excel VBA Tips[ダブルコーテーションの表示]
On Error Resume Next
With CreateObject("WScript.Shell")
Const ARGUMENT_WINDOW_MINIMIZED As Long = 7
.Run "cmd /c" & myCmd, ARGUMENT_WINDOW_MINIMIZED, True
End With
If Err.Number <> 0 Then
MsgBox "エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description, _
vbCritical, "ファイル一覧取得中"
Exit Function
End If
On Error GoTo 0
「CreateObject」関数で、Windows Script Host（WSH）のスクリプト実行環境を作成し、「Run」コマンドでファイル名一覧を作成します。その際、コマンドプロンプトのウィンドウは最小化して、見えなくしています。
また、「7」という数字が何を表しているのかわかるようにするため、それを説明する定数名「ARGUMENT_WINDOW_MINIMIZED」を使って、ウィンドウを最小化する引数ですよ、ということを表しています。
ChDrive myDir: ChDir myDir
この命令で、カレント・ドライブ、カレント・ディレクトリを元の状態に戻します。
If FileLen(List) < 1 Then
MsgBox "該当するファイルがありません。", vbExclamation, _
"ファイル一覧取得中"
Exit Function
End If
変数「List」は「DIR」コマンドの出力結果であるファイル名のリストの一時ファイルです。「FileLen」関数は、「List」ファイルのバイト数を返します。
それが1より小さい、つまり0バイトであるということは、ファイルの中身は何もない、ということです。
したがって、該当するパス名は1つもない、ということになり、「MsgBox」関数で該当するファイルはありません、と表示します。
Dim temp() As Byte
Open List For Binary As #1
ReDim temp(1 To LOF(1))
Get #1, , temp
Close #1
Kill List
一時ファイル「List」は中身を見ればわかりますが、パス名が書いてあるテキストファイルです。それをバイナリモードで開いて、バイト型の配列「temp()」に書き込んでいます。「ReDim temp(1 To LOF(1))」としているのは、ファイルサイズ分の読み込み領域を確保するためです。最後に一時ファイル「List」を削除しています。
Dim FileList() As String
FileList() = Split(StrConv(temp, vbUnicode), vbCrLf)
F_GetTargetList = WorksheetFunction.Transpose(FileList)
End Function
VBAでは、ユニコードで文字を扱いますので、「temp」の文字コードをユニコードに変換します。そのうえで、キャリッジリターン・ラインフィード（CRLF）で文字列を区切ります。そうすると、人間の目にも読めるし、VBAからも読めるファイル名一覧のリストが出来上がります。最後にワークシート関数「Transpose」を使っているのは、横に長い配列になっているリストを、縦に長いリストに変換するための処置です。「動的配列の次元を入れ替える」といいます。
「F_IsEmptyArray」ファンクションプロシージャ
Private Function F_IsEmptyArray(ByRef TargetList() As Variant) _
As Boolean
On Error GoTo HandleError
Application.StatusBar = "開いて保存して閉じる最中… " & _
"進捗状況：ファイル一覧検証中..."
Select Case IsArray(TargetList)
Case True
If UBound(TargetList) >= 0 Then
F_IsEmptyArray = False
Else
F_IsEmptyArray = True
Application.StatusBar = False
MsgBox "配列が空なのでプログラムを終了します。", _
vbExclamation, "空の配列判定中"
End If
Case False
F_IsEmptyArray = True
Application.StatusBar = False
MsgBox "配列が空なのでプログラムを終了します。", _
vbExclamation, "空の配列判定中"
End Select
Exit Function
HandleError:
F_IsEmptyArray = True
Application.StatusBar = False
MsgBox "配列が空なのでプログラムを終了します。", _
vbExclamation, "空の配列判定中"
End Function
ファイル名一覧の一時ファイルは、「TargetList」という名前の配列変数に格納されました。その配列が空でないかどうか確認するファンクションプロシージャです。
取得中だったファイル一覧の内容を確認する段階になったので、ステータスバーのメッセージを「ファイル一覧検証中」に変更します。
配列「TargetList」を「IsArray」関数で本当に配列かどうか判定します。「True」なら配列であり、「False」なら配列ではありません。
配列を「UBound」関数の引数に渡して、戻り値が「0」以上ならば、その配列は空ではありません。「0」未満であれば、その配列は空です。
このファンクションプロシージャでエラーが発生する場合は、そもそも配列ではありません。プログラムのユーザには細かい差異は関係ありませんので、「空でない配列」以外はすべて「空の配列」ということでエラーを出しています。
「F_CheckFileAttribute」ファンクションプロシージャ
Private Function F_CheckFileAttribute _
(ByRef TargetList() As Variant) As Boolean
Application.StatusBar = "開いて保存して閉じる最中… " & _
"進捗状況：ファイル属性確認・変更中..."
Dim Path As Variant
For Each Path In TargetList
If Path <> "" And Path <> ThisWorkbook.FullName _
And Not LCase(Mid(Path, InStrRev(Path, "\") + 1)) Like _
"personal.xls?" Then
Dim myAttribute As VbFileAttribute
myAttribute = GetAttr(Path)
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H4000
myAttribute = myAttribute And Not _
(FILE_ATTRIBUTE_COMPRESSED Or _
FILE_ATTRIBUTE_ENCRYPTED)
If (myAttribute And vbReadOnly) = vbReadOnly Then
myAttribute = (myAttribute And Not vbReadOnly)
End If
On Error Resume Next
SetAttr PathName:=Path, Attributes:=myAttribute
If Err.Number <> 0 Then
If Len(Path) > 50 Then
Path = Left$(Path, InStr(Path, "\")) & _
String(6, ".") & _
Mid$(Path, InStr(Len(Path) - 40, "\"))
End If
MsgBox "ファイルの読み取り専用属性を解除できない" & _
"ものがあるため、処理を終了します。" & _
vbCrLf & _
"ファイル名：" & Path & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description, _
vbCritical, "読み取り専用属性解除不能"
F_CheckFileAttribute = True
Application.StatusBar = False
Exit Function
End If
On Error GoTo 0
End If
Next Path
End Function
上述した部分で、ファイル一覧の配列が空でないことを確認した後は、それぞれのファイルの属性を調べます。
具体的には、読み取り専用属性ではないか、圧縮属性ではないか、暗号属性ではないか、をそれぞれ調べます。
これらの属性を有していると、ファイルがうまく保存できない可能性があるので、手は抜けません。
調べた結果、これらの属性があることがわかったら、「ビット演算」という計算方法を使って、それぞれの属性を解除します。
このビット演算が本プログラムの中で一番難しいかもしれません。このブログを読む方は、VBA初心者の方だと思います。となると、他言語の経験はないと考えたほうがいいと思います。すると、当然「ビット演算」の経験もないでしょうから、基礎もなく、いきなり「ビット演算」に挑むのは、無謀というものです。
このページの「ビットを下ろす」までを理解すれば、本プログラムを理解できるでしょう。「ビットシフト」はここでは扱いませんので、関係ありません。
Dim myAttribute As VbFileAttribute myAttribute = GetAttr(Path) Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800 Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H4000
まず変数「myAttribute」を「VbFileAttribute」列挙型で宣言し、それぞれのファイル名（パス）の属性を取得します。
圧縮属性と暗号属性は「VbFileAttrbute」列挙型に存在しないので、自前で定数を定義します。
「FILE_ATTRIBUTE_COMPRESSED」は圧縮属性、「FILE_ATTRIBUTE_ENCRYPTED」暗号属性です。
myAttribute = myAttribute And Not _
(FILE_ATTRIBUTE_COMPRESSED Or _
FILE_ATTRIBUTE_ENCRYPTED)
変数「myAttribute」と圧縮属性・暗号属性の定数を、「And Not」でビット演算して、圧縮属性・暗号属性のフラグを下ろして、圧縮属性・暗号属性を解除します。
If (myAttribute And vbReadOnly) = vbReadOnly Then
myAttribute = (myAttribute And Not vbReadOnly)
End If
続いて、読み取り専用属性を有していれば、「And Not」でフラグを下ろして、読み取り専用属性を解除します。
On Error Resume Next SetAttr PathName:=Path, Attributes:=myAttribute
「SetAttr」ステートメントで、読み取り専用属性・圧縮属性・暗号属性を解除した属性を、ファイルに設定します。
If Err.Number <> 0 Then
If Len(Path) > 50 Then
Path = Left$(Path, InStr(Path, "\")) & _
String(6, ".") & _
Mid$(Path, InStr(Len(Path) - 40, "\"))
End If
MsgBox "ファイルの読み取り専用属性を解除できない" & _
"ものがあるため、処理を終了します。" & _
vbCrLf & _
"ファイル名：" & Path & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description, _
vbCritical, "読み取り専用属性解除不能"
F_CheckFileAttribute = True
Application.StatusBar = False
Exit Function
End If
On Error GoTo 0
End If
Next Path
End Function
この部分は、エラー処理です。「If Len(Path) > 50 Then」以下の部分は、パスが長い場合に一部を省略して「……」に置き換えて表示する命令です。
「F_IsOpenedFile」ファンクションプロシージャ
Private Function F_IsOpenedFile(ByRef TargetList() As Variant) As Boolean
Dim Path As Variant
For Each Path In TargetList
If Path <> "" And Path <> ThisWorkbook.FullName _
And Not LCase(Mid(Path, InStrRev(Path, "\") + 1)) Like _
"personal.xls?" Then
On Error Resume Next
Open Path For Append As #1
Close #1
If Err.Number <> 0 Then
If Len(Path) > 50 Then
Path = Left$(Path, InStr(Path, "\")) & _
String(6, ".") & _
Mid$(Path, InStr(Len(Path) - 40, "\"))
End If
MsgBox "すでに開いているファイルがあるため、" & _
"処理を終了します。" & vbCrLf & _
"開いているファイルを閉じてから、" & _
"再度プログラムを実行してください。" & _
vbCrLf & "ファイル名：" & Path & _
vbCrLf & "エラー番号：" & Err.Number & _
vbCrLf & "エラー内容：" & Err.Description, _
vbCritical, "開いているファイルの確認中"
F_IsOpenedFile = True
Application.StatusBar = False
Exit Function
End If
On Error GoTo 0
End If
Next Path
End Function
次は、すでに開いているファイルがないか確認します。本プログラムを開始する時点ですでに開いているファイルがあると、そのファイルに対して本プログラムを実行することができません。
そこで、このプロシージャを用いて、開いているファイルをチェックして、もし開いているファイルがある場合は、本プログラムを終了します。
Open Path For Append As #1 Close #1
ファイルを追記モードで開きます。追記モードで開くと、ファイルを開こうとしたとき、そのファイルが他のアプリケーションによって開かれていた場合は、エラーを返します。
そのエラーを手掛かりに、エラーが出た場合は、本プログラムを終了します。
「F_OnlyOpenSaveCloseFiles_Core」ファンクションプロシージャ
Private Function F_OnlyOpenSaveCloseFiles_Core _
(ByRef TargetList() As Variant) As Long
Application.StatusBar = "開いて保存して閉じる最中… " & _
"進捗状況：" & UBound(TargetList) - 1 & _
"件中 1件目の処理準備中..."
Dim Path As Variant
For Each Path In TargetList
If Path <> "" Then
Dim Extension As String
Extension = LCase(Mid(Path, InStrRev(Path, ".") + 1))
Dim File As Object, cnt As Long
On Error Resume Next
Select Case Extension
Case "xls", "xlsx", "xlsm"
Set File = Workbooks.Open _
(Filename:=Path, UpdateLinks:=False, _
IgnoreReadOnlyRecommended:=True)
If GetInputState() = True Then DoEvents
With File
If .ReadOnly = False Then
If ThisWorkbook.FullName <> .FullName _
And Not LCase(.Name) Like _
"personal.xls?" Then
If .MultiUserEditing = True Then
.ExclusiveAccess
End If
If .CheckCompatibility = True Then
.CheckCompatibility = False
End If
cnt = cnt + 1
Application.StatusBar = _
"開いて保存して閉じる最中… " & _
"進捗状況：" & _
UBound(TargetList) - 1 & _
"件中 " & cnt & "件目処理中 ／ " & _
"処理ファイル名：" & .FullName
Call S_HandleExcelWorkbook(File)
End If
End If
End With
Set File = Nothing
Case "doc", "docx", "docm"
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.DisplayAlerts = wdAlertsNone
.Visible = False
End With
Set File = wdApp.Documents.Open(Filename:=Path)
If GetInputState() = True Then DoEvents
With File
If .ReadOnly = False Then
cnt = cnt + 1
Application.StatusBar = _
"開いて保存して閉じる最中… " & _
"進捗状況：" & _
UBound(TargetList) - 1 & _
"件中 " & cnt & "件目処理中 ／ " & _
"処理ファイル名：" & .FullName
Call S_HandleWordDocument(File)
End If
End With
Set File = Nothing
Case "ppt", "pptx", "pptm"
Dim ppApp As Object
Set ppApp = _
CreateObject("Powerpoint.Application")
ppApp.DisplayAlerts = ppAlertsNone
Set File = ppApp.Presentations.Open _
(Filename:=Path, WithWindow:=msoFalse)
If GetInputState() = True Then DoEvents
With File
If .ReadOnly = msoFalse Then
cnt = cnt + 1
Application.StatusBar = _
"開いて保存して閉じる最中… " & _
"進捗状況：" & _
UBound(TargetList) - 1 & _
"件中 " & cnt & "件目処理中 ／ " & _
"処理ファイル名：" & .FullName
Call S_HandlePowerpointPresentation(File)
End If
End With
Set File = Nothing
End Select
On Error GoTo 0
End If
Next Path
wdApp.Quit
Set wdApp = Nothing
ppApp.Quit
Set ppApp = Nothing
F_OnlyOpenSaveCloseFiles_Core = cnt
Application.StatusBar = False
End Function
「Core」とあるとおり、本プログラムの「中心」部分です。このプロシージャで、ファイルを「開く」「保存する」「閉じる」処理をおこないます。
Dim Extension As String Extension = LCase(Mid(Path, InStrRev(Path, ".") + 1))
変数「Extension」に拡張子の文字列を格納します。その拡張子を元に処理を分岐します。
Select Case Extension Case "xls", "xlsx", "xlsm" ～～～～～～～～～～～～～ Case "doc", "docx", "docm" ～～～～～～～～～～～～～ Case "ppt", "pptx", "pptm" ～～～～～～～～～～～～～ End Select
変数「Extension」に格納した拡張子の文字列にもとづいて、Select Case 文で処理を分岐します。
エクセル・ワード・パワポの3つの場合に場合分けして処理を進めます。
Set File = Workbooks.Open _
(Filename:=Path, UpdateLinks:=False, _
IgnoreReadOnlyRecommended:=True)
最初はエクセルです。オブジェクト変数「File」に開いたエクセルファイルを格納します。
引数「UpdateLinks」は、リンクの更新方法を指定します。「False」を指定すると、外部参照、リモート参照ともに更新しません。
引数「IgnoreReadOnlyRecommended」に「True」を指定すると、読み取り推奨メッセージを非表示にします。
If GetInputState() = True Then DoEvents
「DoEvents」関数は、主に低速PC対策の命令です。
時間のかかる処理を実行している場合、ユーザが行った操作は処理が終了するまでオペレーティングシステムに渡りません。そのとき、PCが十分に高速であれば何も問題は起こりませんが、PCが低速の場合、最悪動作が止まって、いわゆる「固まる」状態になります。そんな場合に、処理を中断するときは、DoEvents関数で一時的にWindowsに制御を移します。
すると、PCは命令を受付けるようになり、例えば「Esc」キーを受付けたり、強制終了を受付けたりします。
ところが、そんな便利な「DoEvents」関数も問題があります。
Windowsに制御を渡すと、イベントキューの中身を調べるために極端にスピードが低下します。
そこで「GetInputState」関数を使います。これはイベントキューに待機中のイベントがあるかどうかだけを調べるので、待機中のイベントがあるときだけWindowsに制御を渡します。したがって、余分な確認処理をせずに済み、スピードも落ちなくなります。
With File
If .ReadOnly = False Then
If ThisWorkbook.FullName <> .FullName _
And Not LCase(.Name) Like _
"personal.xls?" Then
～～～～～～～～～～～～～～
End If
End If
End With
ここでは、開いたファイルを「ふるい」にかけています。ファイルが読み取り専用でなく、本プログラムを保存しているファイルとも違い、個人用マクロブックでもないときだけ、処理をします。
If .MultiUserEditing = True Then
.ExclusiveAccess
End If
If .CheckCompatibility = True Then
.CheckCompatibility = False
End If
上記の処理で「ふるい」にかけたファイルですが、まだまだ「保存する」ためには障害が残っています。
共有ブックとして開かれている場合は、色々と制限があるので、排他モードに変更します。
「ExclusiveAccess」メソッドを実行すると、排他モードに変更されます。
まだあります。Excel 2003以前のブックを開くとき、ブックの保存時に互換性チェックが自動的に実行されるかどうかを聞いてくるダイアログが開くときがあります。
そのダイアログが開かないようにするためには、「.CheckCompatibility = False」とします。
cnt = cnt + 1 Application.StatusBar = _ "開いて保存して閉じる最中… " & _ "進捗状況：" & _ UBound(TargetList) - 1 & _ "件中 " & cnt & "件目処理中 ／ " & _ "処理ファイル名：" & .FullName Call S_HandleExcelWorkbook(File)
「cnt = cnt + 1」で、件数を1カウントアップします。
ステータスバーの表示は、1件ごとに変化します。全体の件数を「UBound(TargetList) – 1」としているのは、「TargetList」には、空白行が1行必ず含まれるからです。
ここまでしておいて、オブジェクト変数「File」をサブプロシージャ「S_HandleExcelWorkbook」に渡して処理します。ここでは「保存して閉じる」処理をサブプロシージャに任せています。
ワード・パワポもやり方は同じなので、違う部分だけを説明します。
Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.DisplayAlerts = wdAlertsNone
.Visible = False
End With
ここでは、オブジェクト変数「wdApp」に「Word.Application」オブジェクトを格納して、警告表示を非表示にして、「Word.Application」オブジェクトそのものも非表示にしています。
Dim ppApp As Object
Set ppApp = _
CreateObject("Powerpoint.Application")
ppApp.DisplayAlerts = ppAlertsNone
Set File = ppApp.Presentations.Open _
(Filename:=Path, WithWindow:=msoFalse)
ワードと同じように、オブジェクト変数「ppApp」に「Powerpoint.Application」オブジェクトを格納して、警告表示を非表示にしています。
ワードと違うのは、「Powerpoint.Application」オブジェクトの非表示にするやり方です。
「.Visible = msoFalse」という命令は、MSDNには記述があるものの、実際に実行すると、エラーが出ます。
ですので、パワポファイルを開くときに、パラメータで「WithWindow:=msoFalse」として、オブジェクトそのものを非表示にしています。
F_OnlyOpenSaveCloseFiles_Core = cnt Application.StatusBar = False
変数「F_OnlyOpenSaveCloseFiles_Core」に件数を代入し、ステータスバーの表示を元に戻して終了です。
「S_HandleExcelWorkbook」サブプロシージャ
Private Sub S_HandleExcelWorkbook(ByVal File As Object)
With File
.Save
.Close
End With
End Sub
開いたファイルを引数として受け取って、保存して閉じるだけです。
実際には、ほぼ何もしないプログラムですが、このサブプロシージャこそアイデアの出し所で、次から次へとファイルが開かれるわけですから、そこで何をプログラミングするかはあなた次第というところです。
「S_HandleWordDocument」サブプロシージャ
Private Sub S_HandleWordDocument(ByVal File As Object)
With File
.Saved = False
.Save
.Close
End With
End Sub
エクセルとほぼ同じですが、ワードは1度内容を変更しないと上書き保存できないので、「.Saved = False」として、疑似的に内容を変更した状態を作っています。
ところが、Word 2016では、このような作業をしなくても上書き保存できます。
Word 2010、またはWord 2013までの仕様ではないでしょうか。
「S_HandlePowerpointPresentation」サブプロシージャ
Private Sub S_HandlePowerpointPresentation(ByVal File As Object)
With File
.Save
.Close
End With
End Sub
パワポの場合は、エクセルと同じです。
「S_HideStatusBar」サブプロシージャ
Private Sub S_HideStatusBar(ByVal myStatus As Boolean)
If myStatus = False Then
Application.CommandBars("Status Bar").Visible = False
End If
End Sub
変数「myStatus」の状態を調べ、元々ステータスバーが非表示だった場合に限って、ここでステータスバーを非表示にしています。
「S_ShowResulting」サブプロシージャ
Private Sub S_ShowResulting(ByVal Files As Long, ByVal ElapsedTime As Double)
MsgBox "開いて保存して閉じるだけの処理終了" & vbCrLf & _
"処理ファイル数は " & Files & " 個です。" & vbCrLf & _
"処理時間は " & Round(ElapsedTime, 2) & " 秒です。", _
vbInformation, "開いて保存して閉じるだけのマクロ"
End Sub
最後に処理ファイル数と処理時間を表示して、本プログラムは終了です。
おわりに
今回は「開いて保存して閉じるだけ」のマクロでしたが、様々なテクニックが凝縮されているのがおわかりいただけたでしょうか。
私は、VBA初心者の方には、1つ1つのテクニックを細切れに説明するのではなく、1つのプログラムを作り上げる中で様々なテクニックを有機的につなげているものをお見せするのが必要ではないかと思っています。
今後もそのようなプログラムを作っていきたいと思います。
コメントを残す