○○

Option Compare Database

'**************************************************
' モジュール名  : Mdl_file
' 概要          : ファイル処理
'**************************************************
' FF_IsFile         : ファイル存在検査
' FF_IsFolder       : フォルダ存在検査
' FF_CreateFolder   : フォルダ作成
' FF_CheckReadOnly  : 読込専用ファイル判定
' FF_FileOpenDialog : ファイルオープンダイアログ
' FF_FileSaveDialog : ファイルセーブダイアログ
' FF_FolderDialog   : フォルダ指定ダイアログ
'**************************************************
Option Explicit

' API
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal fileName As String) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

' API用構造体
Private Type OPENFILENAME   ' ファイルオープンダイアログ
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

Private Type BROWSEINFO     ' フォルダ参照ダイアログ
    hwndOwner       As Long
    pidlRoot        As Long
    pszDisplayName  As String
    lpszTitle       As String
    ulFlags         As Long
    lpfn            As Long
    lParam          As Long
    iImage          As Long
End Type

' 定数
Private Const FILE_ATTRIBUTE_READONLY = &H1 ' 読込専用ファイル

Private Const OFN_PATHMUSTEXIST = &H800     ' 存在パス
Private Const OFN_FILEMUSTEXIST = &H1000    ' 存在ファイル
Private Const OFN_HIDEREADONLY = &H4        ' 読込専用

Private Const BIF_RETURNONLYFSDIRS = 1      ' ディレクトリのみ
Private Const MAX_PATH_LEN = 1024           ' ファイルパス

'**************************************************
' 処理名        : ファイル存在検査
' 処理概要      : ファイルの有無を調べる
' 引数          : strPath   ファイルパス
' 戻り値        : True      ファイルあり
'                 False     ファイル無し
'**************************************************
Public Function FF_IsFile(ByVal strPath As String) As Boolean

    Dim fname   As String   ' ファイル名

    FF_IsFile = False

    fname = ""

    If Len(strPath) > 0 Then
        ' 指定パスよりファイル名取得
        fname = Dir(strPath, vbNormal)

        ' 取得文字列長検査
        If Len(fname) > 0 Then
            FF_IsFile = True
        End If
    End If

End Function

'**************************************************
' 処理名        : フォルダ存在検査
' 処理概要      : フォルダの有無を調べる
' 引数          : strPath   フォルダパス
' 戻り値        : True      フォルダあり
'                 False     フォルダ無し
'**************************************************
Public Function FF_IsFolder(ByVal strPath As String) As Boolean

    Dim fname   As String   ' フォルダ名

    FF_IsFolder = False

    fname = ""

    If Len(strPath) > 0 Then
        ' 指定パスよりファイル名取得
        fname = Dir(strPath, vbDirectory)

        ' 取得文字列長検査
        If Len(fname) > 0 Then
            FF_IsFolder = True
        End If
    End If

End Function

'**************************************************
' 処理名        : フォルダ作成
' 処理概要      : パスで指定されたフォルダまでのディレクトリ階層を作る
' 引数          : strPath   フォルダパス
' 戻り値        : True      成功
'                 False     失敗
'**************************************************
Public Function FF_CreateFolder(ByVal strPath As String) As Boolean

    Dim directory() As String
    Dim i           As Integer

    Dim tmp         As String

    FF_CreateFolder = True

    If strPath = "" Then
        FF_CreateFolder = False
        Exit Function
    End If

    directory = Split(strPath, "\")
    If Left(strPath, 2) = "\\" Then
        tmp = "\\" & directory(2)
        i = 3
    Else
        tmp = directory(0)
        i = 1
    End If
    
    ' ディレクトリ数分繰り返し
    While i < UBound(directory)
        tmp = tmp & "\" & directory(i)

        ' ディレクトリ未存在時は作成
        If Not FF_IsFolder(tmp) Then
On Error GoTo ERR_CreateFolder
            MkDir tmp
        End If
        i = i + 1
    Wend

Exit Function

ERR_CreateFolder:
    FF_CreateFolder = False

End Function

'**************************************************
' 処理名        : 読込専用ファイル判定
' 処理概要      : パスで指定されたファイルが読込専用か判定する
' 引数          : strPath   ファイルパス
' 戻り値        : True      読込専用
'                 False     書込可
'**************************************************
Public Function FF_CheckReadOnly(ByVal strPath As String) As Boolean

    Dim attr    As Long     ' ファイル属性

    FF_CheckReadOnly = False

    ' ファイル属性取得
    attr = GetFileAttributes(strPath)
    ' 読込専用判定
    If (attr And FILE_ATTRIBUTE_READONLY) <> 0 Then
        FF_CheckReadOnly = True
    End If

End Function

'**************************************************
' 処理名        : ファイルオープンダイアログ
' 処理概要      : ファイルを開くダイアログを表示する
' 引数          : hWnd      ウィンドウハンドル
'                 strFilter 拡張子指定("拡張子タイトル" & Chr(0) & "*.拡張子" & Chr(0))
' 戻り値        : 成功  ファイルフルパス
'                 失敗  Null文字列
'**************************************************
Public Function FF_FileOpenDialog(ByVal hwnd As Long, ByVal strFilter As String) As String
    
    Dim ofn As OPENFILENAME ' API用構造体
    
    ' 構造体設定
    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = hwnd
    ofn.lpstrFile = String(MAX_PATH_LEN, Chr(0))
    ofn.nMaxFile = MAX_PATH_LEN
    ofn.lpstrFilter = strFilter
    ofn.nFilterIndex = 1
    ofn.lpstrFileTitle = String(MAX_PATH_LEN, Chr(0))
    ofn.nMaxFileTitle = 0
    ofn.lpstrInitialDir = ".\"
    ofn.flags = OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST + OFN_HIDEREADONLY
    
    ' ファイルパス取得
    If GetOpenFileName(ofn) = 0 Then
        FF_FileOpenDialog = ""
    Else
        FF_FileOpenDialog = Trim(ofn.lpstrFile)
        FF_FileOpenDialog = Left(FF_FileOpenDialog, InStr(FF_FileOpenDialog, vbNullChar) - 1)
    End If
    
End Function

'**************************************************
' 処理名        : ファイルセーブダイアログ
' 処理概要      : ファイルを保存するダイアログを表示する
' 引数          : hWnd      ウィンドウハンドル
'                 strFilter 拡張子指定("拡張子タイトル" & Chr(0) & "*.拡張子" & Chr(0))
' 戻り値        : 成功  ファイルフルパス
'                 失敗  Null文字列
'**************************************************
Public Function FF_FileSaveDialog(ByVal hwnd As Long, ByVal strFilter As String) As String

    Dim ofn As OPENFILENAME ' API用構造体
    
    ' 構造体設定
    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = hwnd
    ofn.lpstrFile = String(MAX_PATH_LEN, Chr(0))
    ofn.nMaxFile = MAX_PATH_LEN
    ofn.lpstrFilter = strFilter
    ofn.nFilterIndex = 1
    ofn.lpstrFileTitle = String(MAX_PATH_LEN, Chr(0))
    ofn.nMaxFileTitle = 0
    ofn.lpstrInitialDir = ".\"
    ofn.flags = OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST
    
    ' ファイルパス取得
    If GetSaveFileName(ofn) = 0 Then
        FF_FileSaveDialog = ""
    Else
        FF_FileSaveDialog = Trim(ofn.lpstrFile)
        FF_FileSaveDialog = Left(FF_FileSaveDialog, InStr(FF_FileSaveDialog, vbNullChar) - 1)
    End If
    
End Function

'**************************************************
' 処理名        : フォルダ指定ダイアログ
' 処理概要      : フォルダを指定するダイアログを表示する
' 引数          : hWnd  ウィンドウハンドル
' 戻り値        : 成功  フォルダフルパス
'                 失敗  Null文字列
'**************************************************
Public Function FF_FolderDialog(ByVal hwnd As Long) As String

    Dim udtBrowseInfo   As BROWSEINFO   ' API用構造体
    Dim lpIDList        As Long         ' 選択フォルダのID値

    Dim buff            As String       ' ディレクトリパス格納バッファ

    buff = ""

    ' 親ハンドル設定
    udtBrowseInfo.hwndOwner = hwnd
    ' ディレクトリのみ選択可
    udtBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS

    ' フォルダ参照ダイアログ呼出
    lpIDList = SHBrowseForFolder(udtBrowseInfo)

    ' ディレクトリパス取得
    If lpIDList Then
        buff = String(MAX_PATH_LEN, vbNullChar)
        SHGetPathFromIDList lpIDList, buff
        buff = Left(buff, InStr(buff, vbNullChar) - 1)
        ' 「\」付加
        If Right(buff, 1) <> "\" Then
            buff = buff & "\"
        End If
    End If

    FF_FolderDialog = buff

End Function