MacOS 版 Excel VBA で Dir() 関数の代わり・ファイル一覧を取得する
前回紹介したとおり、Mac 版の Excel VBA では、Dir() 関数がまともに動かない。特に Dir() 関数でファイルの一覧を取得するような処理が全く動かず、Windows 版とは違うコードを書かないといけない。
色々調べてみると、Excel VBA から AppleScript を実行できるので、AppleScript からシェルスクリプトを実行するのが良さそうだ。
試した環境は、MacOS High Sierra、Excel for Mac 2016 (v15.41)。
実際のコード
実行する AppleScript はこんな感じ。
do shell script "find -E '/path/to/directory' -type f -iregex '.*.xlsx' -maxdepth 1"
中身はシェルスクリプト。find コマンドを使って、指定のディレクトリ配下にある、.xlsx ファイルのフルパスを取得する、というモノ。
コレを VBA に組み込んで実行してやる。
' 検索対象のディレクトリ
Dim targetPath As String: targetPath = "/path/to/directory"
' AppleScript を組み立てる
Dim appleScript As String
appleScript = "do shell script ""find -E '" & targetPath & "' -type f -iregex '.*.xlsx' -maxdepth 1"""
' 実行結果を格納する変数
Dim result As String: result = ""
' ファイルが一つもないなど、AppleScript の実行結果でエラーが起こるとエラーイベントが発火するので流す
On Error Resume Next
result = MacScript(appleScript)
On Error GoTo 0
' 改行コード CR で区切り、配列にする
Dim filePaths() As String
filePaths = Split(result, vbCr)
' 1件もデータがない場合は UBound(filePaths) は -1、配列でないモノとみなされるので、空の配列に直す
If UBound(filePaths) < 0 Then
ReDim filePaths(0)
End If
' あとは filePaths をループして使うなり…
' そのまま Workbooks.Open() も呼べる
Workbooks.Open(filePaths(0))
AppleScript を VBA 中で組み立てるところが、可読性が大きく損なわれる。ココは仕方ないか…。
複数行の AppleScript を書きたければ、Chr(13) (= vbCr) を連結することで改行込みのスクリプトが書ける。
今回、'.*.xlsx' という拡張子の絞り込みや、--maxdepth オプションなどは固定で組み込んでしまったが、ココらへんも引数に応じて文字列結合したりしなかったりしても良いだろう。
' AppleScript 中に出てくるダブルクォートを Chr(34) にした
' -iregex を変更して、.xls・.xlsx・.xlsm ファイルがヒットするようにした
appleScript = "do shell script " & Chr(34) & "find -E '" & targetDirectoryPath & "' -type f -iregex '.*.[xls|xlsx|xlsm]' -maxdepth 1" & Chr(34)
find コマンドが Operation not permitted を返すことがある
まだ発生条件やタイミングがよく分かっていなのだが、上述の MacScript() の実行に失敗して、VBA マクロのエラー 5「プロシージャの呼び出し、または引数が不正です。」 が発生することがある。
AppleScript 中のシェルスクリプトに 2>&1 を追記したりして調べてみると、find: : Operation not permitted. エラーが発生していることがある。
確かに、何かの拍子に、マクロを実行中に「このディレクトリやファイルへのアクセス権を付与するか？」みたいなダイアログが出てくることはあるのだが、アクセス権を付与したはずのディレクトリでもマクロ入りブックを再起動したりすると発生したりしなかったりで、タイミングが良く分からなかった。
アクセス権の付与ダイアログが表示されるタイミングが分からず色々難儀だったので、自分の場合は、AppleScript の choose folder を使って、先に find したいディレクトリをユーザに選択させることにした。こうすると上手くアクセス権の付与ダイアログが出てくれることが増えた気がした。
' AppleScript のランタイムエラーを逃がすため指定する
On Error Resume Next
' アクセス権を得たいのでディレクトリ選択ダイアログを表示し、ユーザに選択させる
Dim targetDirectoryPath As String
targetDirectoryPath = MacScript("choose folder as string")
If Err.Number <> 0 Then
' キャンセルされたか AppleScript のランタイムエラーの場合。Exit しておくと良い
End If
' このままだとコロン区切りのパスになっているので、AppleScript を使ってスラッシュを使う POSIX なパスに変換してもらう
targetDirectoryPath = MacScript("tell text 1 thru -2 of " & Chr(34) & targetDirectoryPath & Chr(34) & " to return quoted form of it's POSIX Path")
' 結果がシングルクォートで囲まれた文字列になっているので、用途に応じて削っておいたり
targetDirectoryPath = Replace(targetDirectoryPath, "'", "")
' find コマンドで検索する
Dim appleScript As String: appleScript = "do shell script " & Chr(34) & "find -E '" & targetDirectoryPath & "' -type f -iregex '.*.[xls|xlsx|xlsm]' -maxdepth 1" & Chr(34)
Dim result As String: result = MacScript(appleScript)
If Err.Number <> 0 Then
' シェルスクリプトが異常終了の終了ステータスを返した場合は AppleScript のランタイムエラー扱いになり、エラー 5 としてこのブロックに入る
' find コマンドで Operation not permitted エラーが発生したときもココ
End If
On Error GoTo 0
' 取得したファイル一覧を見る
Debug.Print result
こんな感じ。
参考にした文献
今回のコードは以下の文献より参考にした。
Excel ブックに組み込み済みのモノが Zip ファイルで展開されているので、コードを読みやすいよう以下に転載させていただいた。
module.bas
Option Explicit
'Important: this Dim line must be at the top of your module
Dim MyFiles As String
Sub TestMacroForThisfileWithCellReferences()
Dim MySplit As Variant
Dim FileInMyFiles As Long
Dim Fstr As String
Dim LastSep As String
'Note: I use cell references in this macro to make it easy to test the code
'Normally you will use it like this :
'Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="SearchString")
'Clear MyFiles to be sure that it not return old info if no files are found
MyFiles = ""
'Fill the MyFiles string with the files if they match your criteria
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=Range("F9").Value, ExtChoice:=Range("G9").Value, FileFilterOption:=Range("H9").Value, FileNameFilterStr:=Range("I9").Text)
'Level : 1= Only the files in the folder, 2 to ? levels of subfolders
'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3
'This code below will list all files on the first sheet of this workbook
'In column A :B the path/name, C the file date/time and D the size
'You can browse to the folder you want when the code Run
'In this example we list the file names but you can also use MySplit(FileInMyFiles)
'in the loop to for example to open the files with Workbooks.Open(MySplit(FileInMyFiles))
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
End With
'Delete all cells in columns A:C in the first worksheet of this workbook
Sheets(1).Columns("A:D").Cells.Clear
With Sheets(1).Range("A1:D1")
.Value = Array("Directory", "File Name", "Date/Time", "Size")
.Font.Bold = True
End With
'Split MyFiles and loop through all the files
MySplit = Split(MyFiles, Chr(13))
For FileInMyFiles = LBound(MySplit) To UBound(MySplit)
On Error Resume Next
Fstr = MySplit(FileInMyFiles)
LastSep = InStrRev(Fstr, Application.PathSeparator, , 1)
Sheets(1).Cells(FileInMyFiles + 2, 1).Value = Left(Fstr, LastSep - 1) 'Column A
Sheets(1).Cells(FileInMyFiles + 2, 2).Value = Mid(Fstr, LastSep + 1, Len(Fstr) - LastSep) 'Column B
Sheets(1).Cells(FileInMyFiles + 2, 3).Value = FileDateTime(MySplit(FileInMyFiles)) 'Column C
Sheets(1).Cells(FileInMyFiles + 2, 4).Value = FileLen(MySplit(FileInMyFiles)) 'Column D
On Error GoTo 0
Next FileInMyFiles
Sheets(1).Columns("A:D").AutoFit
With Application
.ScreenUpdating = True
End With
Else
MsgBox "Sorry no files that match your criteria, A 0 files result can be due to Apple sandboxing: Try using the Browse button to re-select the folder."
'Delete all cells in columns A:D in the first worksheet of this workbook
Sheets(1).Columns("A:D").Cells.Clear
'ScreenUpdating is still True but we set it to true again to refresh the screen,
With Application
.ScreenUpdating = True
End With
End If
End Sub
'*******Function that do all the work that will be called by the macro*********
Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 4.0: 27 Sept 2015
'http://www.rondebruin.nl/mac.htm
'Thanks to DJ Bazzie Wazzie and Nigel Garvey(posters on MacScripter)
Dim ScriptToRun As String
Dim folderPath As String
Dim FileNameFilter As String
Dim Extensions As String
On Error Resume Next
folderPath = MacScript("choose folder as string")
If folderPath = "" Then Exit Function
On Error GoTo 0
Select Case ExtChoice
Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)" 'xls, xlsx , xlsm, xlsb
Case 1: Extensions = "xls" 'Only xls
Case 2: Extensions = "xlsx" 'Only xlsx
Case 3: Extensions = "xlsm" 'Only xlsm
Case 4: Extensions = "xlsb" 'Only xlsb
Case 5: Extensions = "csv" 'Only csv
Case 6: Extensions = "txt" 'Only txt
Case 7: Extensions = ".*" 'All files with extension, use *.* for everything
Case 8: Extensions = "(xlsx|xlsm|xlsb)" 'xlsx, xlsm , xlsb
Case 9: Extensions = "(csv|txt)" 'csv and txt files
'You can add more filter options if you want,
End Select
Select Case FileFilterOption
Case 0: FileNameFilter = "'.*/[^~][^/]*\\." & Extensions & "$' " 'No Filter
Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\\." & Extensions & "$' " 'Begins with
Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\\." & Extensions & "$' " ' Ends With
Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\\." & Extensions & "$' " 'Contains
End Select
folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
Chr(34) & " to return quoted form of it's POSIX Path")
folderPath = Replace(folderPath, "'\''", "'\\''")
If Val(Application.Version) < 15 Then
ScriptToRun = ScriptToRun & "set foundPaths to paragraphs of (do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """)" & Chr(13)
ScriptToRun = ScriptToRun & "repeat with thisPath in foundPaths" & Chr(13)
ScriptToRun = ScriptToRun & "set thisPath's contents to (POSIX file thisPath) as text" & Chr(13)
ScriptToRun = ScriptToRun & "end repeat" & Chr(13)
ScriptToRun = ScriptToRun & "set astid to AppleScript's text item delimiters" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to return" & Chr(13)
ScriptToRun = ScriptToRun & "set foundPaths to foundPaths as text" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to astid" & Chr(13)
ScriptToRun = ScriptToRun & "foundPaths"
Else
ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """ "
End If
On Error Resume Next
MyFiles = MacScript(ScriptToRun)
On Error GoTo 0
End Function
Sub SortData()
Dim rng As Range
On Error Resume Next
Set rng = Range("A1").CurrentRegion
rng.Sort key1:=rng.Cells(1, 1), _
order1:=xlAscending, _
Header:=xlNo
Application.ScreenUpdating = True
End Sub
グローバル変数 MyFiles に結果を返すようにしている他、Application.Version が 15 未満の MacOS は AppleScript の書き方が異なる。少し古い Excel for Mac での動作検証はしていないので、上述の簡素化したコードは環境によっては動かないかもしれない。
あとは以前紹介した OS 判定コードと組み合わせて、「Mac では AppleScript を使ってファイル一覧を取得する」「Windows では Dir() 等を使ってファイル一覧を取得する」という風に作ればよかろう。ただ、Dir() 関数はフルパスを返さないことに注意。フルパスを返すよう文字列結合して、配列を返すようにすると、どちらの OS でも同じように関数を使えるようになるだろう。
ちなみに MkDir() は…
ちなみに、MkDir() は、パスをスラッシュ / 区切りで書いてやれば上手くいった。ディレクトリ単体の存在チェックなら Mac でも Dir() 関数が使えたので、以下のようなコードで動作した。
' 起点とするディレクトリ
Dim targetDirectoryPath As String: targetDirectoryPath = "/Users/Neo/work"
' このディレクトリの下に作りたいディレクトリ名
Dim newDirectoryName As String: newDirectoryName = "test"
' パス区切り文字 : ココでは Mac 向けのスラッシュとして定義しておく
Dim pathSplitter As String: pathSplitter = "/"
' 指定のディレクトリ (ココでは /Users/Neo/work/ 配下に test/ ディレクトリ) が存在するかどうか
Dim pathExists As String
' Mac では Dir() の第2引数で vbDirectory の指定が必要
pathExists = Dir(targetDirectoryPath & pathSplitter & newDirectoryName, vbDirectory)
' なければ test/ ディレクトリを作る
If pathExists = "" Then
MkDir targetDirectoryPath & pathSplitter & newDirectoryName
End If
その他参考文献
その他、Mac 版 Excel VBA における Dir() 関数に関する参考文献。
- Dir() function not working in Mac Excel 2011 VBA - Stack Overflow …
Dir()関数の第2引数に指定する MacID について。.xlsxのみ対象にするならMacID("XLSX")で良い