Excel VBA練習 WshShell.Exec("PowerShell -Command -")でファイル一覧を取得

メモ

• FileInfo.DirectoryNameプロパティ相当のつもりで Convert-Path -LiteralPath $_.PSParentPath を使用
• Group-Object でグループ化したオブジェクトを List<GroupInfo>.Sort で並べ替え

使い捨てマクロ

• ファイル名"PowerShell.exe"の検索順序は気にしない

' Excel 2019, Windows 11 (2023年7月頃)

' 参照設定
' Windows Script Host Object Model

Option Explicit

#Const DEBUG_ = False

Public Sub Main()

#If DEBUG_ Then
  Dim wshShell As IWshRuntimeLibrary.wshShell
  Dim wshScriptExec As IWshRuntimeLibrary.wshExec
#Else
  Dim wshShell As Object
  Dim wshScriptExec As Object
#End If

  Set wshShell = VBA.Interaction.CreateObject("WScript.Shell")
  Set wshScriptExec = wshShell.Exec("PowerShell -Command -")

  ' TextStream
  With wshScriptExec.stdIn
    .WriteLine "using namespace System.Collections.Generic"
    .WriteLine "Set-StrictMode -Version Latest"
    .WriteLine "Add-Type -AssemblyName Microsoft.VisualBasic"

    ' テスト用にエラーを発生
    .WriteLine "1 / 0"
    .WriteLine "Write-Error 'non-terminating error' -ErrorAction Continue"

    ' Preference variable
    .WriteLine "$ErrorActionPreference = 'Stop'"

    ' Comparer
    .WriteLine "$Cmp = Add-Type -PassThru -Language CSharp -TypeDefinition @'"
    .WriteLine "namespace MyNS {"
    .WriteLine "  using Microsoft.PowerShell.Commands; using System.Collections.Generic; using System.Management.Automation; using System.Runtime.InteropServices;"
    .WriteLine "  public class CmpStrCmpLogicalW : IComparer<GroupInfo>, IComparer<PSObject> {"
    .WriteLine "    private string propName;"
    .WriteLine "    public CmpStrCmpLogicalW(string propertyName = ""Name"") { this.propName = propertyName; }"
    .WriteLine "    public int Compare(GroupInfo x, GroupInfo y) { return StrCmpLogicalW(x.Name, y.Name); }"
    .WriteLine "    public int Compare(PSObject  x, PSObject  y) { return StrCmpLogicalW(x.Properties[propName].Value.ToString(), y.Properties[propName].Value.ToString()); }"
    .WriteLine "    [DllImport(""Shlwapi.dll"", CharSet = CharSet.Unicode)]"
    .WriteLine "    private static extern int StrCmpLogicalW([MarshalAs(UnmanagedType.LPWStr)] string psz1, [MarshalAs(UnmanagedType.LPWStr)] string psz2);"
    .WriteLine "  }"
    .WriteLine "}"
    .WriteLine "'@ -ReferencedAssemblies Microsoft.PowerShell.Commands.Utility"
    .WriteLine ""

    .WriteLine "try {"
    .WriteLine "  $strPath = [Microsoft.VisualBasic.Interaction]::InputBox('パス', $Host.Name, ""$HOME\Desktop"", -1, -1)"
    .WriteLine "  $grDirName = Get-ChildItem -LiteralPath $strPath -Force -Recurse -Depth 1 | "
    .WriteLine "    Select-Object -Property Attributes, Length, Mode, BaseName, Extension, Name, @{ Name='DirName'; Expression={ Convert-Path -LiteralPath $_.PSParentPath } }, FullName, CreationTime, LastWriteTime | "
    .WriteLine "    Group-Object -Property DirName"
    .WriteLine "  if ($null -eq $grDirName) { return } "
    .WriteLine "  $psObjList = [List[PSObject]]::new()"
    .WriteLine "  $grDirNameList = [List[Microsoft.PowerShell.Commands.GroupInfo]]$grDirName"
    .WriteLine "  $grDirNameList.Sort($Cmp::new())"

    .WriteLine "  $grDirNameList | ForEach-Object {"
    .WriteLine "    # Splatting"
    .WriteLine "    $params = @{ Property = @('Mode', 'Length', 'BaseName', 'Extension', 'DirName', 'FullName', 'CreationTime', 'LastWriteTime') }"
    .WriteLine "    # ディレクトリ"
    .WriteLine "    $list = [List[PSObject]]($_.Group | Where-Object { $_.Attributes -band [IO.FileAttributes]::Directory })"
    .WriteLine "    if ($null -ne $list) { $list.Sort($Cmp::new()); $psObjList.AddRange([List[PSObject]]($list | Select-Object @params)) }"
    .WriteLine "    # ファイル"
    .WriteLine "    $list = [List[PSObject]]($_.Group | Where-Object { -not ($_.Attributes -band [IO.FileAttributes]::Directory) })"
    .WriteLine "    if ($null -ne $list) { $list.Sort($Cmp::new()); $psObjList.AddRange([List[PSObject]]($list | Select-Object @params)) }"
    .WriteLine "  }"
    .WriteLine ""

    .WriteLine "  $psObjList | ConvertTo-Csv -NoTypeInformation"
    .WriteLine "} catch { throw $_ }"
    .WriteLine ""

    .Close
  End With

  Dim strExecOutputs As New VBA.Collection
  Dim strExecErrors As New VBA.Collection

  ' TextStream
  With wshScriptExec.stdOut
    Do While .AtEndOfStream <> True
      strExecOutputs.Add .ReadLine()
    Loop
  End With

  ' TextStream
  With wshScriptExec.stdErr
    Do While .AtEndOfStream <> True
      strExecErrors.Add .ReadLine()
    Loop
  End With

  Set wshScriptExec = Nothing
  Set wshShell = Nothing

  Dim xlWorkbook As Excel.Workbook
  Dim xlWorksheet As Excel.Worksheet
  Dim xlRange As Excel.Range
  Dim str2dArr() As String
  Dim i As Long, N As Long

  Set xlWorkbook = Excel.Workbooks.Add(Excel.XlWBATemplate.xlWBATWorksheet)

  Set xlWorksheet = xlWorkbook.Worksheets.Item(1)
  xlWorksheet.Name = "StdOut"

  N = strExecOutputs.Count

  If N <> 0 Then
    ' N行1列
    ReDim str2dArr(1 To N, 1 To 1)

    For i = 1 To N Step 1
      str2dArr(i, 1) = strExecOutputs(i)
    Next i

    ' 左上セル A1
    Set xlRange = xlWorksheet.Range(xlWorksheet.Cells.Item(1, 1), xlWorksheet.Cells.Item(N, 1))
    xlRange.Value2 = str2dArr

    ' 区切り位置
    xlRange.TextToColumns _
      Destination:=xlWorksheet.Range("A1"), _
      DataType:=Excel.XlTextParsingType.xlDelimited, _
      TextQualifier:=Excel.Constants.xlDoubleQuote, _
      ConsecutiveDelimiter:=False, _
      Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, OtherChar:="", _
      FieldInfo:=Array( _
        Array(1, Excel.XlColumnDataType.xlTextFormat), _
        Array(2, Excel.XlColumnDataType.xlGeneralFormat), _
        Array(3, Excel.XlColumnDataType.xlTextFormat), _
        Array(4, Excel.XlColumnDataType.xlTextFormat), _
        Array(5, Excel.XlColumnDataType.xlTextFormat), _
        Array(6, Excel.XlColumnDataType.xlTextFormat), _
        Array(7, Excel.XlColumnDataType.xlYMDFormat), _
        Array(8, Excel.XlColumnDataType.xlYMDFormat) _
      ), _
      DecimalSeparator:=".", _
      ThousandsSeparator:=",", _
      TrailingMinusNumbers:=True
  End If

  N = strExecErrors.Count

  If N <> 0 Then
    Set xlWorksheet = xlWorkbook.Worksheets.Add(after:=xlWorkbook.Worksheets.Item(1))
    xlWorksheet.Name = "StdErr"

    ' N行1列
    ReDim str2dArr(1 To N, 1 To 1)

    For i = 1 To N Step 1
      str2dArr(i, 1) = strExecErrors(i)
    Next i

    Set xlRange = xlWorksheet.Range(xlWorksheet.Cells.Item(1, 1), xlWorksheet.Cells.Item(N, 1))
    xlRange.Value2 = str2dArr
  End If

  Set xlWorksheet = xlWorkbook.Worksheets.Item(1)
  xlWorksheet.Activate
End Sub