'----------------------------------------------------------------------
'空耳工房 (http://www.grn.mmtr.or.jp/~soramimi/)さんからCopy 1999/04/03
'----------------------------------------------------------------------
Option Compare Database
Option Explicit

'使用可能ドライブを取得
Declare Function GetLogicalDrives Lib "kernel32" () As Long

'使用可能メモリ情報を取得
Type MEMORYSTATUS
    dwLength As Long 'この構造体のサイズ
    dwMemoryLoad As Long 'メモリ使用量(％)
    dwTotalPhys As Long '物理メモリ総容量 (Bytes)
    dwAvailPhys As Long '物理メモリ空容量 (Bytes)
    dwTotalPageFile As Long 'ﾍﾟｰｼﾞﾝｸﾞﾌｧｲﾙに格納できる総容量(Bytes)
    dwAvailPageFile As Long 'ﾍﾟｰｼﾞﾝｸﾞﾌｧｲﾙの空容量(Bytes)
    dwTotalVirtual As Long '呼び出し元のﾌﾟﾛｾｽで使用できる仮想ﾒﾓﾘの総容量(Bytes)
    dwAvailVirtual As Long '予約もコミットもされていない仮想ﾒﾓﾘの空容量(Bytes)
End Type
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

'システムカラーを取得する
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Public Const COLOR_SCROLLBAR = 0 'スクロールバーコントロールの背景
Public Const COLOR_BACKGROUND = 1 'Windowsデスクトップの色
Public Const COLOR_ACTIVECAPTION = 2 'アクティブウインドウのタイトルバー
Public Const COLOR_INACTIVECAPTION = 3 '非アクティブウインドウタイトルバー
Public Const COLOR_MENU = 4 'メニューの背景
Public Const COLOR_WINDOW = 5 'ウインドウの背景
Public Const COLOR_WINDOWFRAME = 6 'ウインドウ枠
Public Const COLOR_MENUTEXT = 7 'メニューの中のテキスト
Public Const COLOR_WINDOWTEXT = 8 'ウインドウのテキスト
Public Const COLOR_CAPTIONTEXT = 9 'タイトルバー、サイズボックス、スクロールバーの矢印のテキスト
Public Const COLOR_ACTIVEBORDER = 10 'アクティブウインドウの境界線
Public Const COLOR_INACTIVEBORDER = 11 '非アクティブウインドウの境界線
Public Const COLOR_APPWORKSPACE = 12 'MDIコンテナのクライアント領域
Public Const COLOR_HIGHLIGHT = 13 'リスト中等の選択された項目の背景色
Public Const COLOR_HIGHLIGHTTEXT = 14 'リスト中等の選択された項目のテキスト
Public Const COLOR_BTNFACE = 15 'ボタンの表面
Public Const COLOR_3DFACE = 15 '3D効果の表面
Public Const COLOR_3DSHADOW = 16 '3D効果の陰影
Public Const COLOR_BTNSHADOW = 16 'ボタンの境界線の影
Public Const COLOR_GRAYTEXT = 17 'グレー状態（使用不可）のテキスト
Public Const COLOR_BTNTEXT = 18 'ボタンのテキスト
Public Const COLOR_INACTIVECAPTIONTEXT = 19 '非アクティブウインドウのテキスト
Public Const COLOR_BTNHILIGHT = 20 'ボタンの境界線のハイライト
Public Const COLOR_3DHILIGHT = 20 '3D効果のハイライト
Public Const COLOR_3DDKSHADOW = 21 '3D効果の暗い陰影
Public Const COLOR_3DLIGHT = 22 '3D効果の明るい色

'フォーマットダイアログを呼び出す
Declare Function SHFormatDrive Lib "Shell32" (ByVal hwnd As Long, ByVal drive As Long, ByVal FmtID As Long, ByVal opt As Long) As Long

Public Const SHFMT_ID_DEFAULT = -1 'デフォルト物理フォーマットID

Public Const SHFMT_OPT_QUICK = 0 'クイックフォーーマット
Public Const SHFMT_OPT_FULL = 1 '通常のフォーマット
Public Const SHFMT_OPT_SYSONLY = 2 '起動専用
Public Const SHFMT_ERROR = -1
Public Const SHFMT_CANCEL = -2
Public Const SHFMT_NOFORMAT = -3

'ファイル操作
Declare Function SHFileOperation Lib "shell32.dll" (lpFileOp As SHFILEOP) As Long
Type SHFILEOP
    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
Public Const FO_COPY = &H2
Public Const FO_MOVE = &H1
Public Const FOF_NOCONFIRMATION = &H10 '上書き確認せずに実行
Public Const FOF_SILENT = &H4 '進行状況ダイアログを表示しない
Public Const FOF_RENAMEONCOLLISION = &H8 'コピー〜をつけてコピー

Public Function LsGetLogicalDrives(drv As String) As Boolean
'引数 : Drv = ドライブの先頭文字
'戻り値: True = 使用可 False = 使用不可
    Dim DrvCD As Integer, rtn As Long
    
    DrvCD = Asc(UCase(Left$(drv, 1))) - Asc("A")
    rtn = GetLogicalDrives()
    LsGetLogicalDrives = ((rtn And 2 ^ DrvCD) <> 0)
End Function

Public Function LsSHFormatDrive(Fm As Form, drv As String) As Long
'*******************************************************************
'機能 : ディスクフォーマットダイアログ
'引数　: fm　= 呼び出し元のフォームオブジェクト
'　　　　Drv = フォーマットするドライブ
'戻り値: -1 = フォーマット中にエラー
'　　　　-2 = キャンセルボタンを押した
'　　　　-3 = フォーマット出来ないドライブを指定した
'　　　　成功 = 物理フォーマットＩＤ
'*******************************************************************
    Dim DrvCD As Long, FormatID As Long, FormatOpt As Long
    
    FormatID = SHFMT_ID_DEFAULT 'デフォルト物理フォーマットID
    FormatOpt = SHFMT_OPT_QUICK 'クイックフォーマット
    DrvCD = Asc(UCase(Left$(drv, 1))) - Asc("A")
    LsSHFormatDrive = SHFormatDrive(Fm.hwnd, DrvCD, FormatID, FormatOpt)
End Function

Public Function LsSHFileOperation(Fm As Form, FromFiles As String, ToPath As String, Sw As Integer)
'*******************************************************************
'機能 : SHFileOperation関数を呼び出し、ファイルのコピー・移動をする
'引数　: Fm　　　 = フォームコントロール
'　　　 FromFile　= コピー・移動元のフルパス名(複数ファイルを指定する時は、ファイル名を　chr$(0)でつなげる)
'　　　 ToPath　　= コピー・移動先のフルパス名
'　　　　Sw　　　　= 0:コピー
'　　　　　　　　　= 1:移動
'備考　: FromFileにフォルダを指定すると、その階層下のサブフォルダ
'　　　　も処理対象になります。
'*******************************************************************
    Dim ShellOp As SHFILEOP
    Dim longret As Long
    Dim func As Long
    Dim flg As Integer

    If Sw = 0 Then
        func = FO_COPY 'ファイルコピー
        flg = 0
        flg = flg + FOF_SILENT '進行状況ダイアログを表示しない
'　　　　flg = flg + FOF_NOCONFIRMATION '上書き確認しない
'　　　　flg = flg + FOF_RENAMEONCOLLISION 'ファイル名に"コピー〜"を付ける
    Else
        func = FO_MOVE 'ファイル移動
        flg = 0
'　　　　flg = flg + FOF_SILENT '進行状況ダイアログを表示しない
'　　　　flg = flg + FOF_NOCONFIRMATION '上書き確認しない
'　　　　flg = flg + FOF_RENAMEONCOLLISION 'ファイル名に"コピー〜"を付ける
    End If
    With ShellOp
        .hwnd = Fm.hwnd
        .wFunc = func
        .pFrom = FromFiles
        .pTo = ToPath
        .fFlags = flg
        .fAnyOperationsAborted = 0
    End With
'ファイル操作
    LsSHFileOperation = SHFileOperation(ShellOp)
End Function