ファイル入出力関係の関数


Public Function OpenTargetFile(ByVal TargetFilePath As String, _
                               ByVal KindSheetName As String, _
                               ByVal RenameString As String) As Boolean
'ファイル名に指定したキーワードを含むXLSファイルを開く
'引数1:TargetFilePath マスタファイルが格納されているファイルパスを渡す
'引数2:KindSheetName   読み込むマスタの種類を示す文字列("役職条件マスタ"など)
'引数3:RenameString    読み込んだマスタのリネーム用文字列
'戻値:成功=TRUE、失敗=FALSE

    Dim wksBook As Workbook   'ワークブックオブジェクト
    Dim wksSheet As Worksheet 'ワークシートオブジェクト
    Dim strName As String     'ファイル名を格納
    Dim strNonExt As String   '拡張子を除外したファイル名を格納
    Dim latestFileName As String  '最新のファイル
    Dim nameLen As Integer    'ファイル名の長さ
    Dim nameDate As String    'シート名の日付文字
    Dim sheetMax As Integer   'シートの最終インデックス
    Dim isChecked As Boolean   'チェックフラグ

    OpenTargetFile = True

    'エラーハンドリング
    On Error GoTo Hdl_ERROR
    
    '最新のファイル名を取得(ファイルの存在確認も兼ねて)
    latestFileName = GetLatestFileName(KindSheetName, TargetFilePath)
    
    '該当ファイルがあったらチェックOK
    If latestFileName <> "" Then
        isChecked = True
    Else
        isChecked = False
    End If
    
    If isChecked = True Then     'ファイル名チェックOKなら実行
    'マスタがバッティングするので古いシートがあったら削除
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name = RenameString Then
                wksSheet.Visible = xlSheetVisible
                Call DeleteSheetFromPartialSheetName(KindSheetName, ThisWorkbook.Name)
                Exit For
            End If
        Next wksSheet
        sheetMax = ThisWorkbook.Worksheets.Count
        Set wksBook = Workbooks.Open(TargetFilePath & "\" & latestFileName) '対象を開く
        Set wksSheet = ThisWorkbook.Worksheets(sheetMax)      '最終のシートを設定し
        wksBook.Worksheets(1).Copy after:=wksSheet          '最終インデックスにコピー
        wksBook.Saved = True                                '上書き確認がうざいので上書き済みにし
        wksBook.Close                                       '対象を閉じる
        sheetMax = ThisWorkbook.Worksheets.Count              'Maxが変わるので再読み込みして
        Set wksSheet = ThisWorkbook.Worksheets(sheetMax)      'オブジェクトをコピー先シートにして
        wksSheet.Name = RenameString                        'シート名を変更
    End If
    
    
    Set wksSheet = Nothing
    Set wksBook = Nothing
    Exit Function
Hdl_ERROR:
    'オブジェクト解放
    Set wksSheet = Nothing
    Set wksBook = Nothing
    OpenTargetFile = False

End Function

Function SaveSheetAsNewBook(ByVal OutputSheet As Worksheet, _
                            Optional ByVal SavefilePath As String = "") As Boolean
'指定したシートを別ブックとして保存
'引数1 OutputSheet: 保存するシートオブジェクト

    Dim newbook As Workbook         '新しいブックオブジェクト
    Dim objBook As Workbook         'このブック格納用オブジェクト
    Dim wksSheet As Worksheet       'ワークシートオブジェクト
    Dim orgSheets As Integer        '呼び出し元シートの「新しいブックのシート数」を格納
    Dim shtIndex As Integer         '新しいブックのシートインデックスを格納
    Dim strSheetName As String      'シート名を格納
    Dim strShtKind As String        'シートの種別を格納
    Dim strDate As String           '日付を格納
    Dim currentPath As String           'このブックのパス
    Dim filePath As String          'ファイルパスを格納
    Dim fileName As String          '出力するファイル名を格納
    Dim fullPath As String          '最終出力ディレクトリまでのフルパスを格納
    Dim isError As Boolean          'エラーフラグ
    Dim fso As FileSystemObject     'ファイル操作用
    Dim strSeqNum As String   '連番格納用
    Dim SeqNum As Integer     '連番

    'エラーハンドリング
    On Error GoTo Hdl_SAVE_ERROR
    
    '渡されたオブジェクトが空オブジェクトか判定
    If IsEmpty(OutputSheet) <> True Then
        '空ならFileSystemObjectを設定する
        Set fso = New FileSystemObject
    Else
        GoTo Hdl_SAVE_ERROR
    End If
    
    '出力ディレクトリの定義
    If SavefilePath = "" Then                          'ディレクトリが指定されていなければ
        currentPath = Application.ThisWorkbook.Path    'カレントにこのブックのパス名を設定
        filePath = currentPath & "\" & STORE_DIR       'マスタファイルの出力ディレクトリ
        strDate = Replace(Format$(Date, "YYYYMMDD"), "/", "")        '本日日付の定義
        fullPath = filePath & "\" & strDate        '最終のフルパス
    Else
        currentPath = SavefilePath                     'カレントディレクトリ
        filePath = SavefilePath                        '指定ディレクトリを設定
        strDate = ""                                   '日付は空にする
        fullPath = filePath
    End If
    
    'オートフィルタの判定
    If OutputSheet.FilterMode = True Then
        OutputSheet.ShowAllData   'オートフィルタモード解除
    End If

    '新しいブックの作成
    orgSheets = Application.SheetsInNewWorkbook     '「新しいブックのシート数」をメモしておく
    strSheetName = OutputSheet.Name                 '現在のシート(コピー元)の名前をメモしておく
    Application.SheetsInNewWorkbook = 1             '新規作成時のデフォルトシート数を1に設定
    Set newbook = Workbooks.Add                     '新しいブックを(メモリ上に)作成
    Application.SheetsInNewWorkbook = orgSheets     '「新しいブックのシート数」を元に戻しておく

    '新しいシートにコピーする
    OutputSheet.Copy before:=newbook.Worksheets(1)
    shtIndex = newbook.Worksheets.Count     'シート数を取得
    Application.DisplayAlerts = False       '確認警告を無効に
    newbook.Worksheets(shtIndex).Delete     '空シートを削除
    Application.DisplayAlerts = True        '確認警告を有効に
    
    '保存の判定
    If SavefilePath = "" Then        '渡されたパス名が空だったら
        If fso.FolderExists(filePath) = False Then '出力ディレクトリがなかったら
            ' カレントの直下に出力フォルダを作成する
            Call fso.CreateFolder(filePath)
            '当日日付ディレクトリがなかったら作成する
            If fso.FolderExists(fullPath) = False Then
                Call fso.CreateFolder(fullPath)
            End If
            'マスタ種別を取得
            strShtKind = JudgeSheetKind(strSheetName)
            
            'マスタ種別が「該当なし」でなければ
            If strShtKind <> "" Then
                '最新の連番を取得し
                SeqNum = GetTargetFileSeq(strShtKind, fullPath)
                'ファイル名を設定し
                fileName = strShtKind & "_" & strDate & "_" & Format$(CStr(SeqNum + 1), "00")
                '保存する
                newbook.SaveAs fullPath & "\" & fileName & ".xls"
                '邪魔なので閉じる
                Application.Workbooks(fileName & ".xls").Close
            End If
        Else
            '当日日付ディレクトリがなかったら作成する
            If fso.FolderExists(fullPath) = False Then
                Call fso.CreateFolder(fullPath)
            End If
             'マスタ種別を取得
            strShtKind = JudgeSheetKind(strSheetName)
            
            'マスタ種別が「該当なし」でなければ
            If strShtKind <> "" Then
                '最新の連番を取得し
                SeqNum = GetTargetFileSeq(strShtKind, fullPath)
                '存在しなければ初期値を設定し
                If SeqNum = -255 Then SeqNum = 0
                'ファイル名を設定し
                fileName = strShtKind & "_" & strDate & "_" & Format$(CStr(SeqNum + 1), "00")
                '保存する
                newbook.SaveAs fullPath & "\" & fileName & ".xls"
                '邪魔なので閉じる
                Application.Workbooks(fileName & ".xls").Close
            End If
        End If
    Else
        SaveSheetAsNewBook = False
        newbook.Close
        Exit Function
    End If
    
    '開いていたブックを閉じる
    
    'オブジェクト解放
    Set fso = Nothing
    Set newbook = Nothing
    '成功を戻す
    SaveSheetAsNewBook = True
    Exit Function
Lbl_NO_MATCH:
   Application.DisplayAlerts = True
   SaveSheetAsNewBook = False
Hdl_SAVE_ERROR:
    'オブジェクト解放
    Set fso = Nothing
    Set newbook = Nothing
    Set objBook = Nothing
    Set wksSheet = Nothing
    Application.DisplayAlerts = True
    '失敗を戻す
    SaveSheetAsNewBook = False
End Function

Function GetTargetFileSeq(ByVal KindTargetFile As String, _
                              ByVal TargetFilePath As String) As Integer
'指定ディレクトリに指定種別のファイルが存在するかチェックし、
'最新ファイルの連番を返す
'
'引数1:KindTargetFile  マスタ種別を表す文字列
'引数2:TargetFilePath  マスタのあるディレクトリ
'戻り値:成功=0以上 存在しない=-255 エラー=-1
    Dim FSO As New FileSystemObject      'FSO
    Dim myFolder As Folder    'フォルダオブジェクト
    Dim objFile As File       'ファイルオブジェクト
    Dim strName As String     'ファイル名を格納
    Dim strNonExt As String   '拡張子を除外したファイル名を格納
    Dim nameLen As Integer    'ファイル名の長さ
    Dim strSeqNum As String   'ファイル連番(文字列)
    Dim SeqNum As Integer     'ファイル連番
    Dim MaxSeq As Integer     '連番の最大値
    Dim matchCount As Integer '存在判定のためのカウンタ
    
    'エラーハンドリング
    On Error GoTo Hdl_ERROR
    
    '初期値設定
    SeqNum = 0
    MaxSeq = 0
    matchCount = 0
    
    'FSOの初期化
    Set FSO = New FileSystemObject
    
    'フォルダオブジェクトの指定
    Set myFolder = FSO.GetFolder(TargetFilePath) 'フォルダオブジェクトのセット
    
    
    'ファイルの読み込み
    For Each objFile In myFolder.Files
        '前方一致でファイル名を検査
        If objFile.Name Like KindTargetFile & "*" & ".xls" Then
            'ファイル名の取得を行う
            strName = objFile.Name                              'ファイル名を取得し
            nameLen = Len(strName)                              'ファイル名の長さを取得し
            strNonExt = FSO.GetBaseName(objFile.Path & _
                                            "\" & objFile.Name) '拡張子抜きのファイル名を取得
            nameLen = Len(strNonExt)                            '長さの補正を行う
            If DateCheck(Mid$(strNonExt, nameLen - 10, 8)) = True Then '日付が埋め込まれているか
                If Mid$(strNonExt, nameLen - 2, 1) = "_" And _
                    IsNumeric(Mid(strNonExt, nameLen - 1, 2)) = True Then  '"_nn"の形式か判定
                    '連番の判定
                    strSeqNum = Mid$(strNonExt, nameLen - 1, 2)
                    If IsNumeric(strSeqNum) = True Then                 '数値だったら
                        SeqNum = CInt(strSeqNum)                        '文字列から数値にして
                        If SeqNum > MaxSeq Then                         '数値の比較を行う
                            MaxSeq = SeqNum
                        End If
                        matchCount = matchCount + 1
                    End If
                End If
            End If
        End If
    Next objFile
    If matchCount = 0 Then
        GetTargetFileSeq = -255
    Else
        GetTargetFileSeq = MaxSeq
    End If
    Exit Function
Hdl_ERROR:
    Set objFile = Nothing
    Set myFolder = Nothing
    Set FSO = Nothing
    GetTargetFileSeq = -1
End Function

Function GetLatestFileName(ByVal KindTargetFile As String, _
                           ByVal TargetFilePath As String) As String
'指定ディレクトリに指定種別のファイルが存在するかチェックし、
'最新ファイルのファイル名を返す
'
'引数1:KindTargetFile  マスタ種別を表す文字列
'引数2:TargetFilePath  マスタのあるディレクトリ
'戻り値:成功=ファイル名,存在しない="",エラー="%"

    Dim fso As New FileSystemObject      'FSO
    Dim myFolder As Folder    'フォルダオブジェクト
    Dim objFile As File       'ファイルオブジェクト
    Dim strName As String     'ファイル名を格納
    Dim strNonExt As String   '拡張子を除外したファイル名を格納
    Dim nameLen As Integer    'ファイル名の長さ
    Dim strSeqNum As String   'ファイル連番(文字列)
    Dim SeqNum As Integer     'ファイル連番
    Dim MaxSeq As Integer     '連番の最大値
    Dim latestFileName As String  '最新ファイル名
    Dim matchCount As Integer '存在判定のためのカウンタ
    
    'エラーハンドリング
    On Error GoTo Hdl_ERROR
    
    '初期値設定
    SeqNum = 0
    MaxSeq = 0
    matchCount = 0
    latestFileName = ""
    
    'FSOの初期化
    Set fso = New FileSystemObject
    
    'フォルダオブジェクトの指定
    Set myFolder = fso.GetFolder(TargetFilePath) 'フォルダオブジェクトのセット
    
    
    'ファイルの読み込み
    For Each objFile In myFolder.Files
        '前方一致でファイル名を検査
        If objFile.Name Like KindTargetFile & "*" & ".xls" Then
            'ファイル名の取得を行う
            strName = objFile.Name                              'ファイル名を取得し
            nameLen = Len(strName)                              'ファイル名の長さを取得し
            strNonExt = fso.GetBaseName(objFile.Path & _
                                            "\" & objFile.Name) '拡張子抜きのファイル名を取得
            nameLen = Len(strNonExt)                            '長さの補正を行う
            If DateCheck(Mid$(strNonExt, nameLen - 10, 8)) = True Then '日付が埋め込まれているか
                If Mid$(strNonExt, nameLen - 2, 1) = "_" And _
                    IsNumeric(Mid(strNonExt, nameLen - 1, 2)) = True Then  '"_nn"の形式か判定
                    '連番の判定
                    strSeqNum = Mid$(strNonExt, nameLen - 1, 2)
                    latestFileName = objFile.Name
                    If IsNumeric(strSeqNum) = True Then                 '数値だったら
                        SeqNum = CInt(strSeqNum)                        '文字列から数値にして
                        If SeqNum > MaxSeq Then                         '数値の比較を行う
                            MaxSeq = SeqNum
                            latestFileName = objFile.Name
                        End If
                        matchCount = matchCount + 1
                    End If
                End If
            End If
        End If
    Next objFile
    If matchCount = 0 Then   '見つからなかったら
        GetLatestFileName = ""
    Else                     '見つかったら
        GetLatestFileName = latestFileName
    End If
    Exit Function
Hdl_ERROR:
    Set objFile = Nothing
    Set myFolder = Nothing
    Set fso = Nothing
    GetLatestFileName = "%"
End Function

Function JudgeSheetKind(ByVal TargetSheetName As String) As String
'指定したシート名で前方から"_"を検索して、"_"の直前までの文字列を取得し、
'ファイル名のルールに沿っているかを判定する
'判定した結果、ルールに沿うならばマスタ種別を表す文字列を返す
    Dim i As Integer                '汎用カウンタ
    Dim myLen As Integer            'シート名の長さ
    Dim myPos   As Variant          '"_"の最初の位置
    Dim strKind As String           '最初の"_"までのシート名
    Dim KindArray(3) As String      'マスタ種別ワードの格納用
    Dim KindMax As Integer          '配列最大値
    Dim bolExistFlg As Boolean      '合致フラグ
    
    'フラグ初期化
    bolExistFlg = False
    
    'マスタ種別ワードの定義
    KindArray(1) = PRFX_ACL
    KindArray(2) = PRFX_KSJ
    KindArray(3) = DIFF_RES_ACL
    
    '"_"の検索
    myPos = InStr(1, TargetSheetName, "_", vbTextCompare)
    
    '文字検索中にエラーが起きたらそのまま抜ける
    If IsNull(myPos) = True Then
        JudgeSheetKind = "False"
        Exit Function
    End If
    
    '検索結果を判定して
    If myPos = 0 Then               '検索結果が0だったら
        '指定文字列をそのまま格納
        strKind = TargetSheetName
    Else                            '検索結果がヒットだったら
        '"_"の直前までの文字列を格納
        strKind = Mid$(TargetSheetName, 1, myPos - 1)
    End If
    KindMax = UBound(KindArray)
    
    '種別の判定
    For i = 1 To KindMax Step 1
        If strKind = KindArray(i) Then
            bolExistFlg = True
            Exit For
        End If
    Next
    
    '結果の通知
    If bolExistFlg = True Then      '該当種別があったら
        JudgeSheetKind = strKind    '種別文字列を返す
    Else
        JudgeSheetKind = ""         'なかったら空を返す
    End If
End Function

'対象シートをCSV化する
'Open strExFileName For Output Access Write As #Fn
'のような感じで事前にファイルをオープンさせておく必要あり
'
Function ExportCSV(ByRef Fn As Integer, ByRef wksTarget As Worksheet) As Long
    Dim RangeNum As Range
    Dim Count As Long
    Dim Limit As Long
    Limit = wksTarget.UsedRange.Columns.Count - 1
    
    On Error GoTo Hdl_ERROR
    
    For Each RangeNum In wksTarget.UsedRange.Rows
        For Count = 1 To Limit
            Write #Fn, "" & Trim(RangeNum.Columns(Count).Text);
        Next Count
        Write #Fn, "" & Trim(RangeNum.Columns(Count).Text)
    Next
    ExportCSV = True
    Exit Function
Hdl_ERROR:
    ExportCSV = Count
End Function