mougにあった質問関連のメモです。
ポータブル デバイスからファイルをコピーする手段として、「Copy/Move Files from Portable Device」ではShellオブジェクトが使われていました。
※ Copy/Move Files from Portable DeviceのコードをVBA向けに直したものが下記になります。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | Option ExplicitPublic 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 WithEnd SubPublic 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でファイルのコピーを行う形ですが、いちいちフォルダーを選択するのは面倒なので、フォルダーを選択する部分を端折った処理を考えてみました。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | Option ExplicitPublic Sub Sample() CopyPDItems "コンピューター\(機種名)\SDカード\DCIM\100MEDIA", "C:\Test" MsgBox "処理が終了しました。", vbInformation + vbSystemModalEnd SubPrivate 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 WithEnd SubPrivate 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 = retEnd Function |
上記コードでは「コンピューター\(機種名)\SDカード\DCIM\100MEDIA」のような形でポータブル デバイス上のフォルダーのパスを指定しています。
エラーの処理等大雑把に書いてありますが、一応手元のスマートフォンで動作確認できました。
このコードを参考にデジカメデータをコピーしていましたが，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