営業日カレンダ作成

0
190
views
Option Explicit
' ####################################################################################################
' # @@ 営業日カレンダ作成.vbs
' # @@      Created Date: 2018.03.03
' # @@      Author      : Hashimoto Natsuki
' ####################################################################################################
' @@ ▼▼ ログ設定 -------------------------------------------------------------------------------------
Const INFO_LEVEL = "[INFO]", WARN_LEVEL = "[WARN]", ERROR_LEVEL = "[EROR]"
Const START_LEVEL = "[STRT]", END_LEVEL = "[END*]"
Const LOG_FOLDER_PATH = "C:\Users\natsuki\Desktop\営業日判定ログ"
Const LOG_FILE_NAME = "eigyoubiApp.log"
Dim logFilePath: logFilePath = LOG_FOLDER_PATH & "\" & LOG_FILE_NAME
' @@ ▼▼ テスト環境設定 @@@@@@ 本番時はコメントアウトすること! @@@@@@ ####################################
Dim executionDate: executionDate = "2017/05/05"
' @@ ▼▼ 本番環境設定 @@@@@@ テスト時はコメントアウトすること! @@@@@@ ####################################
' Dim executionDate: executionDate = Now()
' @@ ▼▼ カレンダ設定 ----------------------------------------------------------------------------------
' @@ 仕様: 処理実施日の翌年のカレンダを作成する
Dim yearOfCalender: yearOfCalender = Year(executionDate) + 1
Const CALENDER_FOLDER_PATH = "C:\Users\natsuki\Desktop\営業日カレンダ"
Dim calenderFileName: calenderFileName = yearOfCalender&"年カレンダ.xlsx"
Dim calenderFilePath: calenderFilePath = CALENDER_FOLDER_PATH&"\"&calenderFileName
' @@ 1週間は7日
Const DAYS_OF_ONE_WEEK = 7
' @@ 曜日配列
Dim weekDaysArray: weekDaysArray = Split("日,月,火,水,木,金,土", ",")
' @@ Excelに描画するカレンダは縦6行×横7列
Dim calenderSquares: calenderSquares = DAYS_OF_ONE_WEEK * 6

logger START_LEVEL, logFilePath, "[proc: 営業日カレンダ作成] 処理を始めます"

If isFileExists(calenderFilePath) = False Then
    Dim monthCalenderArray()
    ReDim monthCalenderArray(12)
    Dim i
    For i = 1 to 12
        monthCalenderArray(i) = buildMonthCalenderArray(DateSerial(yearOfCalender, i, 1))
    Next
    For i = 12 to 1 Step -1
        makeCalenderSheet monthCalenderArray(i), yearOfCalender&"年"&i&"月", calenderFilePath
    Next
End If
Dim holidays': ReDim holidays(27, 5)
holidays = Array( _
    Array("fixed",   1,  1, 1949, 9999, "元日"), _
    Array("fixed",   1, 15, 1949, 1999, "成人の日"), _
    Array("happy",   1,  2, 2000, 9999, "成人の日"), _
    Array("fixed",   2, 11, 1967, 9999, "建国記念の日"), _
    Array("spring",  3,  0, 1949, 9999, "春分の日"), _
    Array("fixed",   4, 29, 1949, 1989, "天皇誕生日"), _
    Array("fixed",   4, 29, 1990, 2006, "みどりの日"), _
    Array("fixed",   4, 29, 2007, 9999, "昭和の日"), _
    Array("fixed",   5,  3, 1949, 9999, "憲法記念日"), _
    Array("fixed",   5,  4, 1988, 2006, "国民の休日"), _
    Array("fixed",   5,  4, 2007, 9999, "みどりの日"), _
    Array("fixed",   5,  5, 1949, 9999, "こどもの日"), _
    Array("happy",   7,  3, 2003, 9999, "海の日"), _
    Array("fixed",   7, 20, 1996, 2002, "海の日"), _
    Array("fixed",   8, 11, 2016, 9999, "山の日"), _
    Array("autumn",  9,  0, 1948, 9999, "秋分の日"), _
    Array("fixed",   9, 15, 1966, 2002, "敬老の日"), _
    Array("happy",   9,  3, 2003, 9999, "敬老の日"), _
    Array("fixed",  10, 10, 1966, 1999, "体育の日"), _
    Array("happy",  10,  2, 2000, 9999, "体育の日"), _
    Array("fixed",  11,  3, 1948, 9999, "文化の日"), _
    Array("fixed",  11, 23, 1948, 9999, "勤労感謝の日"), _
    Array("fixed",  12, 23, 1989, 9999, "天皇誕生日"), _
    Array("fixed",   4, 10, 1959, 1959, "皇太子明仁親王の結婚の儀"), _
    Array("fixed",   2, 24, 1989, 1989, "昭和天皇の大喪の礼"), _
    Array("fixed",  11, 12, 1990, 1990, "即位礼正殿の儀"), _
    Array("fixed",   6,  9, 1993, 1993, "皇太子徳仁親王の結婚の儀") _
)
Dim x, y
Dim printArray
For x = 0 To Ubound(holidays)
    For y = 0 To Ubound(holidays(x))
        printArray = printArray&", "&holidays(x)(y)
    Next
    printArray = printArray&vbCr
Next
MsgBox printArray

Dim dayForCheck: dayForCheck = "2018/08/11"
Dim resultHoliday
resultHoliday = getHoliday(dayForCheck)
MsgBox resultHoliday

logger END_LEVEL, logFilePath, "[proc: 営業日カレンダ作成] 処理が完了しました"
MsgBox "終わり"

' @@ フォルダ作成
' param path フォルダパス
' ============================================================
Function makeFolder(path)
    Dim mfoldFso
    Set mfoldFso = CreateObject("Scripting.FileSystemObject")
    If mfoldFso.FolderExists(path) = False Then
        mfoldFso.CreateFolder(path)
    End If
    Set mfoldFso = Nothing
End Function

' @@ ファイル作成
' param path ファイルパス
' ============================================================
Function makeFile(path)
    Dim mfileFso
    Set mfileFso = CreateObject("Scripting.FileSystemObject")
    If mfileFso.FileExists(path) = False Then
        mfileFso.CreateTextFile(path)
    End If
    Set mfileFso = Nothing
End Function

' @@ ファイル存在チェック
' param path ファイルパス
' ============================================================
Function isFileExists(path)
    Dim ifeFso
    Set ifeFso = CreateObject("Scripting.FileSystemObject")
    If ifeFso.FileExists(path) Then
        Set ifeFso = Nothing
        isFileExists = True
        Exit Function
    End If
    Set ifeFso = Nothing
    isFileExists = False
End Function

' @@ 最下層のフォルダ名を取得
' param path フォルダ絶対パス
' param フォルダ名
' ============================================================
Function getLowestFolderName(path)
    getLowestFolderName = MID(LOG_FOLDER_PATH, _
            InStrRev(LOG_FOLDER_PATH, "\") + 1)
End Function

' @@ ログ出力
' param level   ログレベル
' param path    ログ出力パス
' param message メッセージ
' ============================================================
Function logger(level, path, message)
    Const MODE_READ_WRITE = 3
    Const TYPE_TEXT = 2
    Const AD_WRITE_CHAR = 0
    Const AD_WRITE_LINE = 1
    Const AD_SAVE_CREATE_OVER_WRITE = 2
    makeFolder(LOG_FOLDER_PATH)
    If isFileExists(path) = False Then
        makeFile(path)
    End If
    Dim logStream: Set logStream = CreateObject("ADODB.Stream")
        With logStream
            .Mode = MODE_READ_WRITE
            .Type = TYPE_TEXT
            .charset = "Shift-JIS"
            .Open
    End With
    If isFileExists(path) Then
        With logStream
            .LoadFromFile (path)
            .Position = logStream.Size
        End With
    Else
        'makeFile(path)
    End If
    With logStream
        .WriteText level&" "&Now()&" :"&message, AD_WRITE_LINE
        .SaveToFile path, AD_SAVE_CREATE_OVER_WRITE
        .Close
    End With
    Set logStream = Nothing
End Function

' @@ カレンダ配列作成
' param procDate 対象日
' return カレンダ配列
' ============================================================
Function buildMonthCalenderArray(procDate)
    Dim firstDayConverts2WeekdayAsConstNum
    firstDayConverts2WeekdayAsConstNum = Weekday(procDate)
    Dim daysInProcDateMonth
    daysInProcDateMonth = Day(DateSerial(Year(procDate), Month(procDate) + 1, 1) - 1)
    logger INFO_LEVEL, logFilePath, "処理日:"&procDate&" 曜日:"&firstDayConverts2WeekdayAsConstNum
    Dim buildArray: ReDim buildArray(calenderSquares)
    Dim buildNum
    For buildNum = 0 to (firstDayConverts2WeekdayAsConstNum - 2)
        buildArray(buildNum) = 0
    Next
    Dim dayInSQuare: dayInSQuare = 1
    For buildNum = firstDayConverts2WeekdayAsConstNum - 1 to ((firstDayConverts2WeekdayAsConstNum - 1) + daysInProcDateMonth)
        buildArray(buildNum) = dayInSQuare
        dayInSQuare = dayInSQuare + 1
    Next
    For buildNum = ((firstDayConverts2WeekdayAsConstNum - 1) + daysInProcDateMonth) to calenderSquares
        buildArray(buildNum) = 0
    Next
    buildMonthCalenderArray = buildArray
End Function

' @@ カレンダ配列作成
' param procDate 対象日
' return カレンダ配列
' ============================================================
Function makeCalenderSheet(monthCalender, sheetName, path)
    Dim excelApp
    Dim excelBook
    Dim excelSheets
    Dim excelSheet
    
    On Error Resume Next
    Err.Clear

    makeFolder(CALENDER_FOLDER_PATH)

    ' @@ 起動済かチェックしてExcelオブジェクトを作成
    If Not IsObject(excelApp) Then
        Set excelApp = CreateObject("Excel.Application")
    End If
    ' @@ エラー処理
    If Err Then
        logger ERROR_LEVEL, logFilePath, "Excelを起動できませんでした"
        logger ERROR_LEVEL, logFilePath, "Err.Number:" & Err.Number
        logger ERROR_LEVEL, logFilePath, "Err.Description:" & Err.Description
    End If
    ' @@ 警告を出さないようにする
    excelApp.DisplayAlerts = False
    If isFileExists(path) Then 
        excelApp.Workbooks.Open(path)
    Else
        excelApp.Workbooks.Add
    End If
    ' @@ Excelを非表示にする
    excelApp.Application.Visible = False
    Set excelBook = excelApp.ActiveWorkbook
    Set excelSheets = excelBook.Worksheets
    ' @@ シートを新規に作成
    Set excelSheet = excelApp.Worksheets.Add
    ' @@ セル全体の設定
    With excelSheet
        .Name = sheetName
        .Cells.Font.Size = 18
    End With
    ' @@ セルに年月を表示
    With excelSheet.Range("A1")
            .value = sheetName
            .Font.Bold = True
    End With
    Dim ws
    For Each ws In excelSheets
        If ws.Name = "Sheet1" Then excelSheets("Sheet1").Delete
    Next
    Dim i, row, column
    column = 2
    For i = 0 to Ubound(weekDaysArray)
        With excelSheet.Cells(1, column + i)
            .value = weekDaysArray(i)
            .Font.Bold = True
            .Font.Color = RGB(255, 255, 255)
            .Interior.Color = RGB(0, 46, 99)
            .Borders.LineStyle = 1
            .Borders.Weight = 4
        End With
    Next
    row = 2: column = 2
    For i = 0 to Ubound(monthCalender) - 1
        If monthCalender(i) <> 0 Then
            With excelSheet.Cells(row, column)
                .value = monthCalender(i)
                .Borders.LineStyle = 1
                .Borders.Weight = 4
                If (column = 2) OR (column = 7 + 1) Then
                    .Interior.Color = RGB(251, 174, 210)
                End If
            End With
        Else
            With excelSheet.Cells(row, column)
                .Interior.Color = RGB(85, 85, 85)
                .Borders.LineStyle = 1
                .Borders.Weight = 4
            End With
        End If
        If column = 7 + 1 Then
            column = 1
            row = row + 1
        End If
        column = column + 1
    Next
    column = 10
    For row = 1 to 7
        With excelSheet.Cells(row, column)
            .value = "第"&Chr(Asc("①") + row - 1)&"営業日"
            .Borders.LineStyle = 1
            .Borders.Weight = 4
        End With
        column = column + 1
        With excelSheet.Cells(row, column)
            .value = " ⇒ "
            .Borders.LineStyle = 1
            .Borders.Weight = 0
        End With
        column = column + 1
        With excelSheet.Cells(row, column)
            .Borders.LineStyle = 1
            .Borders.Weight = 4
        End With
        column = 10
    Next
    ' @@ Excelを保存
    excelSheet.Range("A1", "XFD1048576").Rows.AutoFit
    excelSheet.Range("A1", "XFD1048576").Columns.AutoFit
    'excelSheet.Cells(1, 1).EntireRow.AutoFit
    excelBook.SaveAs(path)
    ' @@ Excelの終了
    excelBook.Close
    excelApp.Quit
    'オブジェクトの解放
    Set excelSheet = Nothing
    Set excelSheets = Nothing
    Set excelBook = Nothing
    Set excelApp = Nothing
    logger INFO_LEVEL, logFilePath, "シート"""&sheetName&"""を作成しました"
End Function

' @@ 祝日を取得
' param procDate チェック日
' return 祝日名
' ============================================================
Function getHoliday(procDate)
    Dim result: result = False
    ' @@ 設定された休日チェック
    result = checkHoliday(procDate)
    If result <> False Then 
        getHoliday = result: Exit Function
    End If
    ' @@ 振替休日チェック
    'result = checkTransferHoliday(procDate)
    'If result <> False Then getHoliday = result: Exit Function
    
    ' @@  国民の休日チェック
    'result = checkNationalHoliday(procDate);
    
    getHoliday = result
End Function

' @@ 設定された休日のみチェック
' @@ 国民の休日と振替休日はチェックしない
' param procDate チェック日
' return 祝日名
' ============================================================
Function checkHoliday(procDate)
    Dim result: result = False
    
    ' @@ 全ての祝日を判定
    Dim holiday
    For Each holiday In holidays
        Dim typeHoli, monthHoli, dayHoli, startHoli, endHoli, nameHoli
            typeHoli  = holiday(0)
            monthHoli = holiday(1)
            dayHoli   = holiday(2)
            startHoli = holiday(3)
            endHoli   = holiday(4)
            nameHoli  = holiday(5)
        Select Case typeHoli
            Case "fixed"
                result = getFixedHoliday(procDate, monthHoli, dayHoli, startHoli, endHoli, nameHoli)
        End Select
        If result <> False Then checkHoliday = result: Exit Function
    Next
    checkHoliday = result
End Function

Function getFixedHoliday(procDate, monthCheck, dayCheck, startCheck, endCheck, nameCheck)

    If isWithinYear(procDate, startCheck, endCheck) AND (Month(procDate) = monthCheck) AND (Day(procDate) = dayCheck) Then
        getFixedHoliday = nameCheck: Exit Function
    End If
    getFixedHoliday = False
End Function

Function isWithinYear(procDate, startCheck, endCheck)
    If (startCheck < Year(procDate)) AND (Year(procDate) < endCheck) Then
        isWithinYear = True: Exit Function
    End If
    isWithinYear = False
End Function