名もないSEの備忘録

[Top]

メモ　（サンプルコード）
ポータブルデバイスのフォルダを選択し、ファイルをコピーまたは移動　（Shell.Applicationを使用）

　　コピー：copyFol.copyHere item
　　移動：copyFol.moveHere item

Sub Click(Source As Button)

Dim ShellApp As Variant
Dim fol As Variant
Dim folItem As Variant
Dim SrcFol As Variant
Dim copyFol As Variant
Dim ParentFolderObject As Variant
Dim strDirectoryPath As String
Dim selectFolderTitle As String
Dim selectFolder As String
Dim tempFolder As String
Dim i As Integer


tempFolder = "C:\temp"
Set ShellApp = CreateObject("Shell.Application")
Set fol = ShellApp.BrowseForFolder(0, "ポータブル デバイス上のフォルダーを選択してください。", 0, "")

If fol Is Nothing Then
Msgbox "フォルダを選択してください。"
Exit Sub
Else
Print fol.Title
Print fol.Self.Path

End If

selectFolderTitle = fol.Title
selectFolder = fol.Self.Path


Print "selectFolder: " & selectFolder

' CStr() でキャストする必要しないとエラーが発生
Set SrcFol = ShellApp.Namespace(Cstr(tempFolder))
Set copyFol = ShellApp.Namespace(Cstr(selectFolder))

Dim folder As Variant
Dim item As Variant
Dim chkItem As Variant
Dim copyFolder As Variant

Set folder = SrcFol.Items()
Set copyFolder = copyFol.Items()

If copyFolder.Count > 0 Then
For i = 0 To copyFolder.Count - 1
Set chkItem = copyFolder.Item(Cint( i )) ' CInt() でキャストする必要しないと正常に動作しない
If chkItem.IsFolder = True Then
Print "copyフォルダ" & chkItem.Name
Else
Print "copyフォルダ file 有" & chkItem.Name

Exit Sub
End If
Next

End If

For i = 0 To folder.Count - 1
Set item = folder.Item(Cint( i )) ' CInt() でキャストする必要しないと正常に動作しない
strMsg = strMsg & item.Name & " / " & Cstr(item.Size) & " / " & Cstr(item.ModifyDate) & Chr(13) & Chr(10)
Print strMsg
'移動の場合
'copyFol.moveHere item
'コピーの場合
copyFol.copyHere item
Next
Msgbox strMsg


End Sub

[Top]