Office関連

【2017年7月版】ポータブル デバイスからファイルをコピーするVBAマクロ

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

先日、上記マクロが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 ポータブル デバイス上のファイルやフォルダをマクロから操作したい場合には、上記コードを参考にしていただければと思います。

コメント

  • コメント (1)

  • トラックバックは利用できません。

    • 萩野 明生
    • 2017年 7月 13日

    さっそくのCreators Update対応のソースコード掲載ありがとうございます。
    昨日、自分のツールにも反映して、無事にスマホの写真をWindows PCにインポートできるようになりました。
    最初は、コードが大きく変化したことに戸惑いましたが、Namespaceを使わないコーディングであることに気づいてからはすんなり移植できました。
    ポータブルデバイスに対するVBAのソースコードは希少につき、最初に見つけた時はうれしく、今回の迅速なご対応にも深謝いたします。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP