Office関連

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

mougにあった質問関連のメモです。

ポータブル デバイスからファイルをコピーする手段として、「Copy/Move Files from Portable Device」ではShellオブジェクトが使われていました。

Copy/Move Files from Portable DeviceのコードをVBA向けに直したものが下記になります。

Option Explicit

Public Sub GetFolderPath()
  Dim fol As Object
  
  With CreateObject("Shell.Application")
    Set fol = .BrowseForFolder(0, "ポータブル デバイス上のフォルダーを選択してください。", 0, "")
    If fol Is Nothing Then Exit Sub
    Debug.Print fol.Self.Path
  End With
End Sub

Public Sub CopyItems()
  Dim srcFol As Object, dstFol As Object
  Dim itm As Object
  Const srcFolPath As String = "::{20D04FE0-…" 'GetFolderPathプロシージャーで取得したポータブル デバイス上のフォルダーのパス
  Const dstFolPath As String = "C:\Test" 'コピー先フォルダーのパス
  
  With CreateObject("Shell.Application")
    Set srcFol = .Namespace(srcFolPath)
    Set dstFol = .Namespace(dstFolPath)
    For Each itm In srcFol.Items
      dstFol.CopyHere itm
    Next
  End With
  Debug.Print "処理が終了しました。"
End Sub

BrowseForFolderでポータブル デバイス上のフォルダーのパスを取得して、CopyHereでファイルのコピーを行う形ですが、いちいちフォルダーを選択するのは面倒なので、フォルダーを選択する部分を端折った処理を考えてみました。

Option Explicit

Public Sub Sample()
  CopyPDItems "コンピューター\(機種名)\SDカード\DCIM\100MEDIA", "C:\Test"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub CopyPDItems(ByVal SrcFolderPath As String, ByVal DstFolderPath As Variant)
'ポータブル デバイスにあるフォルダーの中身を指定したフォルダーにコピーする
' - SrcFolderPath:コピー元フォルダーのパス(ポータブル デバイス)
' - DstFolderPath:コピー先フォルダーのパス

  Dim PDFolderPath As Variant
  Dim ParentFolderPath As Variant
  Dim SrcFolder As Object, DstFolder As Object
  Dim itm As Object
  Dim v As Variant
  Dim i As Long, num As Long
  
  PDFolderPath = "": ParentFolderPath = "" '初期化
  If Right(SrcFolderPath, 1) = ChrW(&H5C) Then SrcFolderPath = Left(SrcFolderPath, Len(SrcFolderPath) - 1) '右端のパスセパレーター除去
  v = Split(SrcFolderPath, ChrW(&H5C))
  If v(0) = "コンピューター" Then 'パス最初の「コンピューター」は無視する
    num = 1
  Else
    num = LBound(v)
  End If
  For i = num To UBound(v)
    PDFolderPath = GetPDFolderPath(ParentFolderPath, v(i))
    If Len(PDFolderPath) < 1 Then
      MsgBox "フォルダーが見つかりません。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
    End If
    ParentFolderPath = PDFolderPath
  Next
  With CreateObject("Shell.Application")
    Set SrcFolder = .Namespace(PDFolderPath)
    Set DstFolder = .Namespace(DstFolderPath)
    If SrcFolder Is Nothing Or DstFolder Is Nothing Then
      MsgBox "フォルダーが見つかりません。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
    End If
    On Error Resume Next
    For Each itm In SrcFolder.Items
      DstFolder.CopyHere itm 'フォルダー含めてコピー
    Next
    If Err.Number <> 0 Then MsgBox "エラーが発生しました。" & vbCrLf & vbCrLf & "エラー番号:" & Err.Number & vbCrLf & "エラー内容:" & Err.Description, vbCritical + vbSystemModal
    On Error GoTo 0
  End With
End Sub

Private Function GetPDFolderPath(ByVal ParentFolderPath As Variant, ByVal FolderName As String) As String
  Dim ret As String
  Dim fol As Object
  Dim itm As Object
  
  ret = "": Set fol = Nothing '初期化
  With CreateObject("Shell.Application")
    Set fol = .Namespace(ParentFolderPath)
    If Not fol Is Nothing Then
      For Each itm In fol.Items
        If itm.Name = FolderName Then
          ret = itm.Path
          Exit For
        End If
      Next
    End If
  End With
  GetPDFolderPath = ret
End Function

上記コードでは「コンピューター\(機種名)\SDカード\DCIM\100MEDIA」のような形でポータブル デバイス上のフォルダーのパスを指定しています。
エラーの処理等大雑把に書いてありますが、一応手元のスマートフォンで動作確認できました。

ヘルプファイル版のOffice 2013開発者用リファレンスが公開されました。前のページ

Excel 2013で駅すぱあとWebサービス APIの「経路探索」を使ってみました。次のページ

関連記事

  1. Office関連

    VBA Word 97/98ハンドブックを購入しました。

    ブックオフにあった「VBA Word 97/98ハンドブッ…

  2. Office関連

    Faviconをダウンロードするマクロ

    WebサイトからFaviconを抜き出すAPIがあったので早速使ってみ…

  3. Office アドイン

    office-toolboxを使って簡単にOffice アドインを作成する方法

    以前「YO OFFICE」を使ってOffice アドインのひな型を作成…

  4. Office関連

    [VBA]自動的にフォントサイズを調整する疑似テキストボックス

    前回と同様、環境依存つながりでmougの給湯室に書いたコードを載せてお…

  5. Office関連

    Office 2016のコントロールIDリストが公開されました。

    昨年の秋にリリースされたOffice 2016。そのコントロールI…

  6. Office関連

    [Excel Services ECMAScript]ループによる入力と一括入力の処理時間について

    埋め込んだExcelワークブックのセルに対して、ループで1セルずつ入力…

コメント

    • bagino
    • 2017年 7月 11日 6:55am

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

    • > bagino さん

      当ブログ管理人です。
      Windows 10 Pro Insider Preview バージョン:10.0.16237 ビルド 16237で動作確認したところ、たしかに動作しなくなっておりました。

      一部処理を書き換えたコードを記事にしましたので↓、こちらをご参照ください。

      https://www.ka-net.org/blog/?p=8670

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP