4年ほど前に、PCに接続したスマートフォン等のWindows ポータブル デバイスからファイルやフォルダをコピーするマクロについて記事を書きました。

2013.09.30

ポータブル デバイスからファイルをコピーするVBAマクロ

mougにあった質問関連のメモです。 ポータブル デバイスからファイルをコピーする手段として、「Copy/Move Files from Portable Device」ではShellオブジェクトが使われていました。 ※ Copy/Move F...

先日、上記マクロがWindows 10 Creators Update環境で動作しなくなったとのコメントをいただいたので、コードを書き直すことにしました。

このコードを参考にデジカメデータをコピーしていましたが，Windows10 1703　Cretors update　に上げてから，Namespaceの部分が動かくなくなりました。
Shell32.dllが，2017/6/20のタイムスタンプになっており，差し変わったことが原因と推測します。
色々トライしましたが，回避策がなくて困っています。

Option Explicit

Public Sub Sample()
  CopyWpdItems "内部ストレージ\data\jp.co.yahoo.android.yjwidget_sbm", _
               "C:\Test\WPD", _
               "Xperia Z Ultra"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub CopyWpdItems(ByVal SrcFolderPath As String, _
                         ByVal TargetFolderPath As Variant, _
                         Optional ByVal WpdName As String = "")
'Windows ポータブル デバイス(WPD)にあるフォルダの中身を指定したフォルダにコピー
'- SrcFolderPath:コピー元フォルダのパス
'- TargetFolderPath:コピー先フォルダのパス
'- WpdName:WPD名(接続されているWPDが一つしかない場合は指定する必要無し)
  Dim Wpd As Object
  Dim ParentFolder As Object
  Dim Srcfolder As Object
  Dim TargetFolder As Object
  Dim itm As Object
  Dim v As Variant
  Dim i As Long
  
  'コピー先フォルダチェック
  With CreateObject("Scripting.FileSystemObject")
    If .FolderExists(TargetFolderPath) = False Then
      MsgBox "コピー先フォルダが見つかりませんでした。" & vbNewLine & _
             "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
    End If
  End With
  
  'WPD取得
  Set Wpd = GetWpd(WpdName)
  If Wpd Is Nothing Then
    MsgBox "ポータブル デバイスを取得できませんでした。" & vbNewLine & _
           "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  Set ParentFolder = Wpd
  
  'コピー元フォルダ取得
  v = Split(SrcFolderPath, ChrW(&H5C))
  For i = LBound(v) To UBound(v)
    Set Srcfolder = GetWpdChildFolder(ParentFolder, v(i))
    If Srcfolder Is Nothing Then
      MsgBox "コピー対象のフォルダが見つかりません。" & vbNewLine & _
             "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
    End If
    Set ParentFolder = Srcfolder
  Next
  
  'ファイル/フォルダコピー
  With CreateObject("Shell.Application")
    Set TargetFolder = .Namespace(TargetFolderPath)
    On Error Resume Next
    For Each itm In Srcfolder.Items
      TargetFolder.CopyHere itm 'フォルダー含めてコピー
    Next
    If Err.Number <> 0 Then
      MsgBox "エラーが発生しました。" & vbNewLine & vbNewLine & _
             "エラー番号：" & Err.Number & vbNewLine & _
             "エラー内容：" & Err.Description, vbCritical + vbSystemModal
    End If
    On Error GoTo 0
  End With
End Sub

Private Function GetWpd(Optional ByVal WpdName As String = "") As Object
'Windows ポータブル デバイス(WPD)を取得
'※WPDが複数接続されている場合は引数で名前を指定
  Dim ret As Object
  Dim itm As Object
  
  Set ret = Nothing '初期化
  With CreateObject("Shell.Application").Namespace("shell:MyComputerFolder")
    For Each itm In .Items
      Select Case itm.Type
        Case "ポータブル メディア プレーヤー", "ポータブル デバイス"
          If Len(Trim(WpdName)) < 1 Then
            Set ret = itm.GetFolder
          Else
            If itm.Name = WpdName Then
              Set ret = itm.GetFolder
            End If
          End If
      End Select
    Next
  End With
  Set GetWpd = ret
End Function

Private Function GetWpdChildFolder(ByVal ParentFolder As Object, _
                                   ByVal ChildFolderName As String) As Object
  Dim ret As Object
  Dim itm As Object
  
  Set ret = Nothing '初期化
  For Each itm In ParentFolder.Items
    If (itm.IsFolder = True) And (itm.Name = ChildFolderName) Then
      Set ret = itm.GetFolder
      Exit For
    End If
  Next
  Set GetWpdChildFolder = ret
End Function

FolderItemオブジェクトのTypeプロパティによってポータブル メディア プレーヤー(ポータブル デバイス)かどうかを判別して目的のフォルダを取得、FolderオブジェクトのCopyHereメソッドによってファイルやフォルダのコピーを行っています。

Windows ポータブル デバイス上のファイルやフォルダをマクロから操作したい場合には、上記コードを参考にしていただければと思います。