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

Outlook REST APIに会議室情報を取得するAPIが追加されました。前のページ

IEを操作するVBAマクロ実行中にオートメーションエラーが発生する場合の対処法次のページ

関連記事

  1. Office関連

    Office 2010 開発者用リファレンスをHTML形式で”快適に”閲覧す…

    前回の記事で7-Zipを使ってHXS形式のOffice製品のヘルプを解…

  2. アイコン一覧

    Office 2013 アイコン一覧(E)

    ・Office 2013 アイコン一覧 NUM…

  3. Office関連

    Office製品のヘルプをHTML形式で閲覧する。

    「Word2013 VBA の日本語ヘルプ」で回答した通り、Offic…

  4. Office関連

    目次を更新するWordマクロ

    文書の目次を更新するにはTableOfContentsオブジェクトのU…

  5. Office関連

    Excel 2013 新関数一覧

    「関数一覧(Excel 2010)」と「関数一覧(Excel 2013…

  6. Office アドイン

    Office アドインの概要と開発方法を学ぶための自習書

    2018年10月27日(土)、品川の日本マイクロソフト本社で「2018…

コメント

  • コメント (2)

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

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

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

    • 寺澤
    • 2019年 1月 28日

    Excel VBA でのスマホとPCでのファイルのやり取りで3年悩んでいましたが、大変助かりましたありがとうございます。感謝です。

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP