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- Advertisement -
