Attribute VB_Name = "xSHFileOperation関数" ' @(h) xSHFileOperation関数.bas ver 1.0 ( '98.10.15 ) ' @(s) ' フォルダの操作を行うモジュール ' 本モジュールはテスト用コードモジュールです。 ' 注意).本API関数はOSR2以前のバージョンでは使用できません。 ' 但し、どうしても使いたいときはIE4.01以降をインストールしてください。 ' Option Explicit '' API関数定義 Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long '' 命令 Public Const FO_COPY = &H2 '' ファイルをコピー Public Const FO_DELETE = &H3 '' ファイルを削除 Public Const FO_MOVE = &H1 '' ファイルを移動 Public Const FO_RENAME = &H4 '' ファイル名を変更 '' オプション Public Const FOF_ALLOWUNDO = &H40 '' 可能な場合、アンドゥ情報を保存する Public Const FOF_CONFIRMMOUSE = &H2 '' Public Const FOF_FILESONLY = &H80 '' コピー元ファイル名に"."が指定したことを示す Public Const FOF_MULTIDESTFILES = &H1 '' pToに複数のコピー先を指定したことを示す Public Const FOF_NOCONFIRMATION = &H10 '' 問い合わせに対して「はい」を選んだことにする Public Const FOF_NOCONFIRMMKDIR = &H200 '' 新しいディレクトリを作るようなことはしない。 Public Const FOF_RENAMEONCOLLISION = &H8 '' コピー先に同じ名前があるときは「のコピー1」というような名前にする Public Const FOF_SILENT = &H4 '' 進行状況を示すダイアログを表示しない。 Public Const FOF_SIMPLEPROGRESS = &H100 '' 進行状況を示すダイアログにファイル名を表示しない Public Const FOF_WANTMAPPINGHANDLE = &H20 '' '' SHFILEOPSTRUCT Type SHFILEOPSTRUCT hwnd As Long '' ハンドル=0でよい wFunc As Long '' 命令 pFrom As String '' コピー元 pTo As String '' コピー先 fFlags As Integer '' オプション fAnyOperationsAborted As Long '' ? - 失敗したときに呼び出す関数のアドレス? hNameMappings As Long '' ? - 名前を出力するハンドル? lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS(=0) End Type Sub xSHFileOperationのテスト() Dim xPath As String Dim I As Long Dim xFreeFile As Long xPath = ActiveWorkbook.Path '' エクセルを前提にしてます。 '' ハードディスクは90MB以上必要です。 On Error Resume Next MkDir xPath & "\テストフォルダ" MkDir xPath & "\テストフォルダ\test1" On Error GoTo 0 MsgBox "「" & xPath & "\テストフォルダ\test1」を作成しましたので確認してください。" xFreeFile = FreeFile Open xPath & "\テストフォルダ\test1\TEST01.BIN" For Output As #xFreeFile Print #xFreeFile, String(3000000, "X") Close #xFreeFile For I = 2 To 10 Step 1 FileCopy xPath & "\テストフォルダ\test1\TEST01.BIN", xPath & "\テストフォルダ\test1\TEST" & Right$("00" & I, 2) & ".BIN" Next I MsgBox "10ファイル作成しました。「" & xPath & "\テストフォルダ\test1」を確認してください。" xDirCopy xPath & "\テストフォルダ\test1", xPath & "\テストフォルダ\test2" xDirCopy2 xPath & "\テストフォルダ\test1", xPath & "\テストフォルダ\test3" MsgBox "「" & xPath & "\テストフォルダ\test1」をコピーして「test2」と「test3」を作成しました。確認してください。" xDirRename xPath & "\テストフォルダ\test3", xPath & "\テストフォルダ\test456fg" MsgBox "「" & xPath & "\テストフォルダ\test3」を「test456fg」にリネームしました。確認してください。" xDirMove xPath & "\テストフォルダ\test456fg", xPath & "\テストフォルダ\test1" MsgBox "「" & xPath & "\テストフォルダ\test456fg」を「test1」に移動しました。確認してください。" xDirDelete xPath & "\テストフォルダ" MsgBox "「" & xPath & "\テストフォルダ」を削除しました。確認してください。" End Sub ' @(f) ' ' 機能 : フォルダを削除する。 ' ' 返り値 : なし ' ' 引き数 : xFromFile - 削除するフォルダ名 ' ' 機能説明 : フォルダを削除する。(アンドゥ情報は保存しません) ' ' 備考 : 特になし ' Function xDirDelete(ByVal xFromFile As String) Dim shfos As SHFILEOPSTRUCT Dim result As Long Dim AnyOperationsAborted As Long Dim NameMappings As Long With shfos .hwnd = 0 .wFunc = FO_DELETE .pFrom = xFromFile .pTo = "" .fFlags = 0 .fAnyOperationsAborted = AnyOperationsAborted .hNameMappings = NameMappings .lpszProgressTitle = 0 End With result = SHFileOperation(shfos) DoEvents End Function ' @(f) ' ' 機能 : フォルダを移動する。 ' ' 返り値 : なし ' ' 引き数 : xFromFile - 移動元フォルダ名 ' xToFile - 移動先フォルダ名 ' ' 機能説明 : フォルダを移動する。(アンドゥ情報は保存しません) ' ' 備考 : 特になし ' Function xDirMove(ByVal xFromFile As String, ByVal xToFile As String) Dim shfos As SHFILEOPSTRUCT Dim result As Long Dim AnyOperationsAborted As Long Dim NameMappings As Long With shfos .hwnd = 0 .wFunc = FO_MOVE .pFrom = xFromFile .pTo = xToFile .fFlags = 0 .fAnyOperationsAborted = AnyOperationsAborted .hNameMappings = NameMappings .lpszProgressTitle = 0 End With result = SHFileOperation(shfos) DoEvents End Function ' @(f) ' ' 機能 : フォルダ名をかえる。 ' ' 返り値 : なし ' ' 引き数 : xFromFile - 元のフォルダ名 ' xToFile - 先のフォルダ名 ' ' 機能説明 : フォルダ名をかえる。(アンドゥ情報は保存しません) ' ' 備考 : 特になし ' Function xDirRename(ByVal xFromFile As String, ByVal xToFile As String) Dim shfos As SHFILEOPSTRUCT Dim result As Long Dim AnyOperationsAborted As Long Dim NameMappings As Long With shfos .hwnd = 0 .wFunc = FO_RENAME .pFrom = xFromFile .pTo = xToFile .fFlags = 0 .fAnyOperationsAborted = AnyOperationsAborted .hNameMappings = NameMappings .lpszProgressTitle = 0 End With result = SHFileOperation(shfos) DoEvents End Function ' @(f) ' ' 機能 : フォルダをコピーする。 ' ' 返り値 : なし ' ' 引き数 : xFromFile - コピー元のフォルダ名 ' xToFile - コピー先のフォルダ名 ' ' 機能説明 : フォルダをコピーする。(コピー情報を表示しません。) ' ' 備考 : 特になし ' Function xDirCopy2(ByVal xFromFile As String, ByVal xToFile As String) Dim shfos As SHFILEOPSTRUCT Dim result As Long Dim AnyOperationsAborted As Long Dim NameMappings As Long With shfos .hwnd = 0 .wFunc = FO_COPY .pFrom = xFromFile .pTo = xToFile .fFlags = FOF_SILENT .fAnyOperationsAborted = AnyOperationsAborted .hNameMappings = NameMappings .lpszProgressTitle = 0 End With result = SHFileOperation(shfos) DoEvents End Function ' @(f) ' ' 機能 : フォルダをコピーする。 ' ' 返り値 : なし ' ' 引き数 : xFromFile - コピー元のフォルダ名 ' xToFile - コピー先のフォルダ名 ' ' 機能説明 : フォルダをコピーする。(コピー情報を表示します。) ' ' 備考 : 特になし ' Function xDirCopy(ByVal xFromFile As String, ByVal xToFile As String) Dim shfos As SHFILEOPSTRUCT Dim result As Long Dim AnyOperationsAborted As Long Dim NameMappings As Long With shfos .hwnd = 0 .wFunc = FO_COPY .pFrom = xFromFile .pTo = xToFile .fFlags = 0 .fAnyOperationsAborted = AnyOperationsAborted .hNameMappings = NameMappings .lpszProgressTitle = 0 End With result = SHFileOperation(shfos) DoEvents End Function