#112 エクスプローラ風のファイルコピー VBA、API

エクスプローラのコピーダイアログAccessのVBAには、ファイルをコピーする手段として「FileCopyステートメント」が用意されています。しかし、WindowsAPIを使うと、エクスプローラでファイルのコピーを実行したときと同じように、紙がフォルダからフォルダへとヒラヒラ飛んでいく、あのダイアログを表示させながらファイルのコピーを実行させることができます。

それには"SHELL32.DLL"にあるWindowsAPIの「SHFileOperation」関数を使用します。

まず標準モジュールに次のコードを記述します。"Type"および"Declare"の前に、"Private"を付けることによってフォームのモジュールにも記述できます。
Type SHFILEOPSTRUCT
  hwnd As Long
  wFunc As Long
  pFrom As String
  pTo As String
  fFlags As Integer
  fAnyOperationsAborted As Long
  hNameMappings As Long
  lpszProgressTitle As String
End Type

Declare Function SHFileOperation Lib "SHELL32.DLL" Alias _
                      "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Const FO_COPY = &H2
Const FO_MOVE = &H1
Const FOF_NOCONFIRMATION = &H10
Const FOF_RENAMEONCOLLISION = &H8

次の例では、ファイル"c:\My Documents\Test.mdb"を"c:\Test.mdb"にコピーします。
Dim stShellOp As SHFILEOPSTRUCT
Const cstrSrcFile As String = "c:\My Documents\Test.mdb"
Const cstrDstFile As String = "c:\Test.mdb"

With stShellOp
  'Accessのハンドルをセット
  .hwnd = Application.hWndAccessApp
  'コピーモードを指定
  .wFunc = FO_COPY    '移動時は FO_MOVE
  'コピー元ファイルのフルパスをセット
  .pFrom = cstrSrcFile
  'コピー先ファイルのフルパスをセット
  .pTo = cstrDstFile
  '.fFlags = FOF_NOCONFIRMATION
  '.fFlags = FOF_RENAMEONCOLLISION
End With

'コピーを実行
If SHFileOperation(stShellOp) = 0 Then
  Beep
  MsgBox "コピー完了しました!"
Else
  Beep
  MsgBox "コピーに失敗またはキャンセルされました!"
End If

  • 上書き確認のダイアログ上記のコードを実行したとき、同名のファイルがすでに存在する場合も、もちろんエクスプローラと同様に上書き確認のダイアログが表示されます。
  • コピー先のフォルダが存在しない場合、新規作成するかどうかの確認ダイアログが表示されます。
  • With stShellOp 〜 End With の間に次の1行を追加すると、同名のファイルがすでに存在する場合に上書き確認のダイアログを表示せず、強制的に上書きコピーします。
        .fFlags = FOF_NOCONFIRMATION
  • With stShellOp 〜 End With の間に次の1行を追加すると、同名のファイルがすでに存在する場合に上書き確認のダイアログを表示せず、「コピー 〜 Test.mdb」というような名前のファイルとしてコピーします。
        .fFlags = FOF_RENAMEONCOLLISION
  • "FO_COPY"の替りに、wFuncに"FO_MOVE"を指定すると「ファイルの移動」になります。
※エクスプローラでもそうですが、小さなサイズのファイルをコピーする場合にはこのようなダイアログは表示されません。動作確認する場合は、サイズの大きいファイルで試してみてください。
| Index | Prev | Next |

この情報は参考になりましたか?、問題は解決しましたか?、もしまだなら......
T'sWareのワンポイトテクニカルアドバイスをご利用ください。3000円/件〜でご支援します。
スタンドアロンからSQL Server対応まで、オーダーメイドのシステムを短納期・安価でお届けします
 

Copyright © T'sWare All rights reserved