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 2013]SkyDriveを無効(非表示)にする。

    「Office 2013 SkyDrive 無効」というキーワードで検…

  2. Office関連

    外部からOutlookのマクロを実行するマクロ

    外部からOutlookのマクロを実行するマクロ今回は外部からO…

  3. Office関連

    Office 365 unified APIをJavaScriptだけで呼び出す

    Microsoftの松崎さんのブログに下記の記事がありました。…

  4. Office関連

    Microsoft MVP for Outlook を初受賞しました。

    2010年7月から「Office System」分野でMicrosof…

  5. アイコン一覧

    Office 2013 アイコン一覧(X,Y,Z)

    ・Office 2013 アイコン一覧 NUM…

  6. Office アドイン

    [Office用アプリ]サポートページにある資料へのリンクをまとめてみました。

    MicrosoftのサポートページにあるOffice 用アプリや関連技…

コメント

  • コメント (2)

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

    • 萩野 明生
    • 2017年 7月 13日 12:43pm

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

    • 寺澤
    • 2019年 1月 28日 1:17pm

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP