Attribute VB_Name = "xSHFileOperation関数"
' @(h) xSHFileOperation関数.bas                                     ver 1.0 ( '98.10.15  )

' @(s)
'  フォルダの操作を行うモジュール
'  本モジュールはテスト用コードモジュールです。
'  注意).本ＡＰＩ関数はＯＳＲ２以前のバージョンでは使用できません。
'        但し、どうしても使いたいときはＩＥ４．０１以降をインストールしてください。
'
Option Explicit
'' ＡＰＩ関数定義
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                                     '' エクセルを前提にしてます。
                                                                    '' ハードディスクは９０ＭＢ以上必要です。
    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 "１０ファイル作成しました。「" & 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