HOMEへ

ファイルシートディレクトリ======================================================

Option Explicit

'**
' ファイル　ファイル名　取得
'  固定されたファイル名の取得
'------------------------------------------------------------------
Sub FileName()

    Dim FileName As String
    FileName = "c:\test\book1.xlsx"
    Workbooks.Open FileName

End Sub

'**
' シート　有無チェック
'  @param {FileName : string}
'  @return {SheetCheck : Boolean}
'------------------------------------------------------------------
Function SheetCheck(FileName As String) As Boolean
    
    Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name = FileName Then
            SheetCheck = True
            Exit Function
        End If
    Next

    SheetCheck = False

End Function

'**
' シート　インデックス　取得
'  @param {FileName : string}
'  @return {SheetIndexCheck : Integer}
'------------------------------------------------------------------
Function SheetIndexCheck(FileName As String) As Integer
    
    Dim i  As Integer
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = FileName Then
            SheetIndexCheck = i
            Exit Function
        End If
    Next

    SheetIndexCheck = 0

End Function

'**
' ファイル　ダイアログ
'  @param {FileName : string} オープンパス
'                 {ViewType : string} 表示ファイル "ex" or "tx"
'  @return {GetFilePath : string} パス名
'------------------------------------------------------------------
Function GetFilePath(ByVal FileName As String, ByVal ViewType As String) As String

With Application.FileDialog(msoFileDialogFilePicker)
    .Filters.Clear
    .Filters.Add "Excelファイル", "*.xlsx;*.xlsm"
    
    If ViewType = "tx" Then
        .Filters.Clear
        .Filters.Add "テキストファイル", "*.txt;*.csv;*.prn"
    End If

    .FilterIndex = 1
    .InitialFileName = FileName
    .AllowMultiSelect = False
    .Title = "ファイルの選択"
    .ButtonName = "開く"

    If .Show = True Then
        Dim PathName As Variant
        Dim MyPrompt As String
        
        For Each PathName In .SelectedItems
            MyPrompt = MyPrompt & vbCrLf & CStr(PathName)
            MyPrompt = CStr(PathName)
        Next
    
    End If

End With

GetFilePath = MyPrompt

End Function

'**
' ファイル　ダイアログ
'
'------------------------------------------------------------------
Sub GetOpenFileName()

    Dim TargetFileName As Variant
    
    '戻り値はファイルパス(文字列) or boolean型(選択しなかった場合)
    TargetFileName = Application.GetOpenFileName("Microsoft Excelブック,*.xls?")
    If VarType(TargetFileName) = vbBoolean Then
        MsgBox "キャンセルされました"
    Else
        Workbooks.Open TargetFileName
    End If

End Sub

'**
' ディレクトリ　有無チェック
'  @param {pathName : string} ディレクトリパス
'  @return {DirCheck : boolean}
'------------------------------------------------------------------
Function DirCheck(ByVal PathName As String) As Boolean

    DirCheck = False
    If Dir(PathName, vbDirectory) <> "" Then DirCheck = True

End Function

'**
' ディレクトリ　ファイル　有無チェック
'  @param {pathName : string} ディレクトリパス
'                 {headWord : string} ファイル名頭文字
'  @return {DirFileCheck : boolean}
'------------------------------------------------------------------
Function DirFileCheck(ByVal PathName As String, ByVal headWord As String) As Boolean

    DirFileCheck = False
    
    PathName = Dir(PathName & "\" & headWord & "*.*")
    Dim cnt As Integer: cnt = 0
    
    Do While PathName <> ""
        cnt = cnt + 1
        PathName = Dir()
    Loop

    If cnt > 0 Then DirFileCheck = True

End Function

'**
' ファイル　ファイル名　有無チェック
'  @param {FileName : string} チェック対象ファイル名
'                 {KeyWord : string} チェック基準キーワード
'                 {CheckType : string} チェックタイプ  "match" or "like"
'  @return {SelectFileNameCheck : boolean}
'------------------------------------------------------------------
Function SelectFileNameCheck(ByVal FileName As String, ByVal KeyWord As String, ByVal CheckType As String) As Boolean

    SelectFileNameCheck = False
    If CheckType = "match" Then
        If FileName = KeyWord Then SelectFileNameCheck = True
    
    Else
       'チェック基準キーワードをファイル名と拡張子に分割
        Dim FileParts() As String
        FileParts = Split(KeyWord, ".")
        If (FileName Like "*" & FileParts(0) & "*") And (FileName Like "*" & FileParts(1)) Then SelectFileNameCheck = True
    
    End If

End Function

'**
' ブック　チェック　開かれているか
'  @param {FilePath : string} ファイルパス
'
'  @return {IsBookOpened : boolean}
'------------------------------------------------------------------
Function IsBookOpened(ByVal FilePath As String) As Boolean

    On Error Resume Next

    Open FilePath For Append As #1
    Close #1

    If Err.Number > 0 Then
        IsBookOpened = True
    Else
        IsBookOpened = False
    End If

End Function

'**
' ブック　チェック　開かれているか
'
'------------------------------------------------------------------
Public Sub BookOpenCheck()

    Dim bk As Workbook
    Dim fPath As String

    fPath = "C:\Users\menta\Desktop\ExcelVBA\名簿.xlsm"
    For Each bk In Workbooks
        If fPath = bk.FullName Then
            MsgBox "ブックは開いてます"
            Exit For
        End If
    Next bk

End Sub

'**
' フォルダ　作成
'------------------------------------------------------------------
Public Sub CreateFolder(ByVal FolderPath As String)

    MkDir FolderPath

End Sub

'**
' フォルダ　コピー
'------------------------------------------------------------------
Public Sub FsoCopyFolder()

    With New FileSystemObject

        'コピー先パス
        Dim myDestination As String: myDestination = "C:\Users\menta\Desktop\sampleDB\"
        'コピー元パス
        With .GetFolder("C:\Users\menta\Desktop\sample_test")
            .SubFolders("hoge").Copy myDestination
            .SubFolders("foo").Move myDestination
            .SubFolders("hoge").Delete
        End With

    End With

End Sub

'**
' フォルダ　作成
'------------------------------------------------------------------
Public Sub FsoCreateFolder()

    With New FileSystemObject

        Dim myPath As String: myPath = ThisWorkbook.Path
        Dim myFolders As Folders: Set myFolders = .GetFolder(myPath).SubFolders

        myFolders.Add "piyo"
        .CreateFolder myPath & "\foo"

    End With

End Sub

'**
' フォルダ　参照
'------------------------------------------------------------------
Public Sub FolderReference()

    '参照設定 → Microsoft Scripting Runtime ※参照設定しない場合は以下が必要
    'Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    With New FileSystemObject

        Dim myPath As String: myPath = ThisWorkbook.Path
        Dim myFolders As Folders: Set myFolders = .GetFolder(myPath).SubFolders

        Debug.Print myFolders.Item("hoge").Name
        Debug.Print myFolders("hoge").Name
        Debug.Print myFolders.Count

        Dim myFolder As Folder
        For Each myFolder In myFolders
            Debug.Print myFolder.Name
        Next myFolder
    
    End With

End Sub

'**
' ファイル　参照
'------------------------------------------------------------------
Public Sub FileReference()

    '参照設定 → Microsoft Scripting Runtime ※参照設定しない場合は以下が必要
    'Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    With New FileSystemObject

        Dim myPath As String: myPath = ThisWorkbook.Path
        Dim myFiles As Files: Set myFiles = .GetFolder(myPath).Files

        Debug.Print myFiles.Item("aaa.txt").Name
        Debug.Print myFiles("bbb.txt").Name
        Debug.Print myFiles.Count

        Dim myFile As File
        For Each myFile In myFiles
            Debug.Print myFile.Name
        Next myFile
    
    End With

End Sub

'**
' ファイル　コピー
'------------------------------------------------------------------
Public Sub FsoCopyFile()

    With New FileSystemObject

        'コピー先パス
        Dim myDestination As String: myDestination = "C:\Users\menta\Desktop\sampleDB\"
        'コピー元パス
        With .GetFolder("C:\Users\menta\Desktop\sample_test")
            .Files("aaa.txt").Copy myDestination
            .Files("bbb.txt").Move myDestination
            .Files("aaa.txt").Delete
        End With

    End With

End Sub

'**
' テキストファイル　オープン
' 日本語は文字化け
'------------------------------------------------------------------
Public Sub FsoOpenFile()

    With New FileSystemObject
        'ファイルパス
        Dim myPath As String: myPath = ThisWorkbook.Path & "\sample.txt"

        'ファイルオープン
        With .GetFile(myPath).OpenAsTextStream
            Debug.Print .ReadLine
            .Close
        End With

        With .OpenTextFile(myPath)
            Debug.Print .ReadLine
            .Close
        End With
    End With

End Sub

'**
' テキストファイル　オープン
' 日本語の文字化け対策
'------------------------------------------------------------------
Public Sub FsoOpenFile1()

    With New FileSystemObject
        'ファイルパス
        Dim myPath As String: myPath = ThisWorkbook.Path & "\sample.txt"

        'ストリーム
        With CreateObject("ADODB.Stream")
            .Charset = "UTF-8"
            .Open
            .LoadFromFile (myPath)
            Debug.Print .ReadText
            .Close
        End With
    
    End With

End Sub

'**
' テキストファイル　オープン
' 日本語の文字化け対策
' CSVファイルなど「,」で区切られ、行毎に改行コードがあるデータ用
'------------------------------------------------------------------
Public Sub OpenTextFile1()

    'ファイルパス
    Dim myPath As String: myPath = ThisWorkbook.Path & "\sample.txt"

    Dim buf As String, i As Long
    Dim tmp1 As Variant, tmp2 As Variant, j As Long

    'ストリーム
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile myPath
         buf = .ReadText
        .Close

        '格納した全行データ(buf)を改行コードで分割して再度配列に格納
        tmp1 = Split(buf, vbCrLf)
        For i = 0 To UBound(tmp1)
            tmp2 = Split(tmp1(i), ",")
            '///tmp2を処理
        Next i
    End With

End Sub

'**
' テキストファイル　オープン
' 日本語の文字化け対策
' CSVファイルなど「,」で区切られ、行毎に改行コードがあるデータ用
'------------------------------------------------------------------
Public Sub OpenTextFile2()

    'ファイルパス
    Dim myPath As String: myPath = ThisWorkbook.Path & "\sample.txt"

    Dim buf As String, i As Long
    Dim tmp As Variant, j As Long

    'ストリーム
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile myPath

        Do Until .EOS
            '1行ずつデータを取得(この場合、引数は-2を指定)
            buf = .ReadText(-2)
            i = i + 1
            tmp = Split(buf, ",")
            For j = 0 To UBound(tmp)
                Debug.Print tmp(j)
            Next j
        Loop
        .Close
    End With

End Sub

'**
' ブック　保存　上書き　Excel　閉じる
'------------------------------------------------------------------
Public Sub ThisBookSave()

    Application.DisplayAlerts = False

    With ThisWorkbook
        .Save
        .Close
    End With

    Application.DisplayAlerts = True

End Sub

'**
' ブック　保存　ブックカウント　Excel　閉じる
'------------------------------------------------------------------
Public Sub SaveAndExcelQuit()

    Application.DisplayAlerts = False

    With ThisWorkbook
        .Save
        If Workbooks.Count <= 1 Then Application.Quit
    End With

    Application.DisplayAlerts = True

End Sub

Public Sub newBookSave()

    Dim newbook As Workbook
    Set newbook = ThisWorkbook
    Dim savePath As String
    savePath = ThisWorkbook.Path & "\"

    With newbook.Worksheets(1)
        .Activate
    End With

    Application.DisplayAlerts = False
        newbook.SaveAs savePath & "aaaa" & "_" & Format(Date, "mmddyyyy") & ".xlsx", xlOpenXMLWorkbook
    Application.DisplayAlerts = True

End Sub


Public Sub newBookSave(ByVal savePath As String, ByVal fileName As String)

    Dim newbook As Workbook
    
    ThisWorkbook.Worksheets.Copy
    Set newbook = ActiveWorkbook

    Application.DisplayAlerts = False
        newbook.SaveAs savePath & "\" & fileName & ".xlsx", xlOpenXMLWorkbook
    Application.DisplayAlerts = True

End Sub


Public Sub newBookSave(obj As Workbook, ByVal savePath As String, ByVal fileName As String)

    Dim shell As Object
    Dim upDateFolder As Object
    Dim upDateFile As Object

    Set shell = createObject("Shell.Application") ' インスタンス化

    Application.DisplayAlerts = False
        obj.SaveAs savePath & "\" & fileName & ".xlsx", xlOpenXMLWorkbook
        Set upDateFolder = shell.Namespace(savePath & "\")
        Set upDateFile = upDateFolder.ParseName(fileName & ".xlsx")
        upDateFile.ModifyDate = Now ' 更新日時を変更

        Set upDateFolder = Nothing
        Set upDateFile = Nothing
        Set shell = Nothing
    Application.DisplayAlerts = True

End Sub