Option Explicit
' ==========================================
' 共通空き時間 抽出：フォーム自動生成 or 自動フォールバック版
' ==========================================
' ===== 営業時間（必要に応じて変更） =====
Private Const BUSINESS_START_HOUR As Long = 9
Private Const BUSINESS_START_MIN As Long = 0
Private Const BUSINESS_END_HOUR As Long = 18
Private Const BUSINESS_END_MIN As Long = 0
' ===== Free/Busy ステータス =====
Private Enum OlFreeBusyStatus
fbFree = 0
fbTentative = 1
fbBusy = 2
fbOutOfOffice = 3
fbWorkingElsewhere = 4
End Enum
' 参加者（フォーム/フォールバック両用）
Private mRecips As Outlook.Recipients
' 祝日キャッシュ
Private mHolidayCache As Object ' Dict: Year -> Dict(Date->True)
' ──────────────────────────────
' エントリポイント
' ──────────────────────────────
Public Sub Run_CommonFreeTimes()
If TryShowAutoForm() Then
Exit Sub
Else
' フォーム不可環境 → フォールバックUIで実行
FindCommonFreeTimes_Fallback
End If
End Sub
' ──────────────────────────────
' 1) フォーム自動生成（VBOM可） or False
' ──────────────────────────────
Private Function TryShowAutoForm() As Boolean
On Error Resume Next
' VBOMにアクセスできるか（信頼設定ON かつ アンチウイルス等がブロックしていないか）
Dim vbProj As Object
Set vbProj = Application.VBE.ActiveVBProject
If Err.Number <> 0 Or vbProj Is Nothing Then
Err.Clear
TryShowAutoForm = False
Exit Function
End If
' 生成
Dim frmName As String: frmName = "frmCommonFreeTimes"
EnsureRemoveVBComponentIfExists frmName
' 追加できるか事前テスト
Dim vbComp As Object
Set vbComp = vbProj.VBComponents.Add(3) ' 3 = vbext_ct_MSForm
If vbComp Is Nothing Then
TryShowAutoForm = False
Exit Function
End If
vbProj.VBComponents.Remove vbComp ' 一旦消し、改めて正規生成
BuildUserForm frmName
' 表示
VBA.UserForms.Add(frmName).Show
TryShowAutoForm = True
End Function
' ── フォーム構築（安定版） ──
Private Sub BuildUserForm(ByVal frmName As String)
Dim vbProj As Object, vbComp As Object, designer As Object, ctl As Object
Set vbProj = Application.VBE.ActiveVBProject
Set vbComp = vbProj.VBComponents.Add(3) ' vbext_ct_MSForm
vbComp.Name = frmName
Set designer = vbComp.Designer
' タイトル
Set ctl = designer.Controls.Add("Forms.Label.1", "lblHeader", True)
With ctl
.Caption = "共通空き時間 抽出"
.Left = 12: .Top = 8: .Width = 240
.Font.Bold = True
End With
' 開始・終了
designer.Controls.Add "Forms.Label.1", "lblStart", True
With designer.Controls("lblStart"): .Caption = "開始": .Left = 12: .Top = 36: .Width = 36: End With
designer.Controls.Add "Forms.TextBox.1", "txtStart", True
With designer.Controls("txtStart")
.Left = 60: .Top = 32: .Width = 160
.Value = Format(Date + TimeSerial(9, 0, 0), "yyyy/m/d HH:nn")
End With
designer.Controls.Add "Forms.Label.1", "lblEnd", True
With designer.Controls("lblEnd"): .Caption = "終了": .Left = 232: .Top = 36: .Width = 36: End With
designer.Controls.Add "Forms.TextBox.1", "txtEnd", True
With designer.Controls("txtEnd")
.Left = 280: .Top = 32: .Width = 160
.Value = Format(DateAdd("d", 7, Date) + TimeSerial(18, 0, 0), "yyyy/m/d HH:nn")
End With
' 粒度・会議分
designer.Controls.Add "Forms.Label.1", "lblSlot", True
With designer.Controls("lblSlot"): .Caption = "粒度(分)": .Left = 12: .Top = 64: .Width = 56: End With
designer.Controls.Add "Forms.ComboBox.1", "cboSlot", True
With designer.Controls("cboSlot")
.Left = 72: .Top = 60: .Width = 60
.AddItem "5": .AddItem "10": .AddItem "15": .AddItem "30": .AddItem "60"
.Value = "30"
End With
designer.Controls.Add "Forms.Label.1", "lblDur", True
With designer.Controls("lblDur"): .Caption = "会議(分)": .Left = 148: .Top = 64: .Width = 56: End With
designer.Controls.Add "Forms.TextBox.1", "txtDuration", True
With designer.Controls("txtDuration"): .Left = 204: .Top = 60: .Width = 48: .Value = "60": End With
' オプション
designer.Controls.Add "Forms.CheckBox.1", "chkTentative", True
With designer.Controls("chkTentative"): .Caption = "仮の予定(1)も空き": .Left = 264: .Top = 60: .Width = 120: .Value = False: End With
designer.Controls.Add "Forms.CheckBox.1", "chkExcludeWeekends", True
With designer.Controls("chkExcludeWeekends"): .Caption = "土日を除外": .Left = 12: .Top = 88: .Width = 90: .Value = True: End With
designer.Controls.Add "Forms.CheckBox.1", "chkExcludeHolidays", True
With designer.Controls("chkExcludeHolidays"): .Caption = "祝日を除外": .Left = 110: .Top = 88: .Width = 90: .Value = True: End With
designer.Controls.Add "Forms.CheckBox.1", "chkExcludeLunch", True
With designer.Controls("chkExcludeLunch"): .Caption = "昼休み(12-13)除外": .Left = 208: .Top = 88: .Width = 120: .Value = True: End With
designer.Controls.Add "Forms.CheckBox.1", "chkIncludeMe", True
With designer.Controls("chkIncludeMe"): .Caption = "自分を含める": .Left = 332: .Top = 88: .Width = 100: .Value = True: End With
' 参加者選択
designer.Controls.Add "Forms.CommandButton.1", "btnPickRecipients", True
With designer.Controls("btnPickRecipients"): .Caption = "参加者を選択": .Left = 12: .Top = 116: .Width = 100: End With
designer.Controls.Add "Forms.Label.1", "lblRecipients", True
With designer.Controls("lblRecipients"): .Caption = "(未選択)": .Left = 120: .Top = 120: .Width = 320: End With
' 実行系
designer.Controls.Add "Forms.CommandButton.1", "btnRun", True
With designer.Controls("btnRun"): .Caption = "抽出": .Left = 12: .Top = 148: .Width = 60: End With
designer.Controls.Add "Forms.CommandButton.1", "btnCopy", True
With designer.Controls("btnCopy"): .Caption = "コピー": .Left = 80: .Top = 148: .Width = 60: End With
designer.Controls.Add "Forms.CommandButton.1", "btnMail", True
With designer.Controls("btnMail"): .Caption = "メール作成": .Left = 148: .Top = 148: .Width = 80: End With
designer.Controls.Add "Forms.CommandButton.1", "btnClose", True
With designer.Controls("btnClose"): .Caption = "閉じる": .Left = 234: .Top = 148: .Width = 60: End With
' 結果
designer.Controls.Add "Forms.ListBox.1", "lstResults", True
With designer.Controls("lstResults"): .Left = 12: .Top = 180: .Width = 428: .Height = 220: End With
' フォームサイズ
With designer: .Width = 460: .Height = 420: End With
' フォームのイベントコードを注入
Dim cm As Object: Set cm = vbComp.CodeModule
Dim code As String
code = "Option Explicit" & vbCrLf & _
"Private Sub btnPickRecipients_Click(): SetRecipientsViaDialog Me: End Sub" & vbCrLf & _
"Private Sub btnRun_Click(): ExecuteExtraction Me: End Sub" & vbCrLf & _
"Private Sub btnCopy_Click(): CopyResults Me: End Sub" & vbCrLf & _
"Private Sub btnMail_Click(): CreateMailFromResults Me: End Sub" & vbCrLf & _
"Private Sub btnClose_Click(): Unload Me: End Sub"
cm.InsertLines 1, code
End Sub
Private Sub EnsureRemoveVBComponentIfExists(ByVal name As String)
On Error Resume Next
Dim vbComp As Object
Set vbComp = Application.VBE.ActiveVBProject.VBComponents(name)
If Not vbComp Is Nothing Then Application.VBE.ActiveVBProject.VBComponents.Remove vbComp
Err.Clear
End Sub
' ──────────────────────────────
' 2) フォームから呼ばれる処理
' ──────────────────────────────
Public Sub SetRecipientsViaDialog(frm As Object)
Dim ns As Outlook.NameSpace: Set ns = Application.Session
Dim snd As Outlook.SelectNamesDialog: Set snd = ns.GetSelectNamesDialog
With snd
.Caption = "参加者を選択"
.NumberOfRecipientSelectors = OlRecipientSelectors.olShowTo
.ToLabel = "参加者"
.ForceResolution = True
.AllowMultipleSelection = True
If Not .Display Then Exit Sub
End With
Set mRecips = snd.Recipients
frm.Controls("lblRecipients").Caption = IIf(mRecips Is Nothing Or mRecips.Count = 0, "(未選択)", RecipientsToString(mRecips))
End Sub
Public Sub ExecuteExtraction(frm As Object)
On Error GoTo EH
If mRecips Is Nothing Or mRecips.Count = 0 Then
MsgBox "参加者を選択してください。", vbExclamation: Exit Sub
End If
Dim startDt As Date, endDt As Date
If Not TryParseDate(frm.Controls("txtStart").Value, startDt) Then MsgBox "開始日時が不正です。", vbExclamation: Exit Sub
If Not TryParseDate(frm.Controls("txtEnd").Value, endDt) Then MsgBox "終了日時が不正です。", vbExclamation: Exit Sub
If endDt <= startDt Then MsgBox "終了は開始より後にしてください。", vbExclamation: Exit Sub
Dim slotMin As Long, needMin As Long
If Not IsNumeric(frm.Controls("cboSlot").Value) Then MsgBox "粒度（分）は数値です。", vbExclamation: Exit Sub
slotMin = CLng(frm.Controls("cboSlot").Value)
If slotMin <= 0 Or 1440 Mod slotMin <> 0 Then MsgBox "粒度は1440を割り切れる整数です。", vbExclamation: Exit Sub
If Not IsNumeric(frm.Controls("txtDuration").Value) Then MsgBox "会議分は数値です。", vbExclamation: Exit Sub
needMin = CLng(frm.Controls("txtDuration").Value)
If needMin <= 0 Then MsgBox "会議分は正の整数です。", vbExclamation: Exit Sub
Dim treatTentative As Boolean: treatTentative = frm.Controls("chkTentative").Value
Dim excludeWeekends As Boolean: excludeWeekends = frm.Controls("chkExcludeWeekends").Value
Dim excludeHolidays As Boolean: excludeHolidays = frm.Controls("chkExcludeHolidays").Value
Dim excludeLunch As Boolean: excludeLunch = frm.Controls("chkExcludeLunch").Value
Dim includeMe As Boolean: includeMe = frm.Controls("chkIncludeMe").Value
If includeMe Then EnsureCurrentUserIncluded Application.Session, mRecips
Dim totalMin As Long, nSlots As Long, minSlots As Long
totalMin = DateDiff("n", startDt, endDt)
nSlots = totalMin \ slotMin
If nSlots <= 0 Then MsgBox "期間が短すぎます。", vbExclamation: Exit Sub
minSlots = (needMin + slotMin - 1) \ slotMin
Dim allFree() As Boolean
ReDim allFree(1 To nSlots)
Dim j As Long: For j = 1 To nSlots: allFree(j) = True: Next
Dim i As Long, iSlot As Long
For i = 1 To mRecips.Count
Dim rcp As Outlook.Recipient: Set rcp = mRecips(i)
If Not rcp.Resolve Then MsgBox "解決できない参加者: " & rcp.Name, vbExclamation: Exit Sub
Dim fbCache As Object: Set fbCache = CreateObject("Scripting.Dictionary")
For iSlot = 1 To nSlots
Dim slotStart As Date, slotEnd As Date
slotStart = DateAdd("n", (iSlot - 1) * slotMin, startDt)
slotEnd = DateAdd("n", iSlot * slotMin, startDt)
If Not IsSlotBusinessEligible(slotStart, slotEnd, excludeWeekends, excludeHolidays, excludeLunch) Then
allFree(iSlot) = False
Else
Dim dayStart As Date: dayStart = DateSerial(Year(slotStart), Month(slotStart), Day(slotStart))
Dim fbDay As String
If fbCache.Exists(dayStart) Then
fbDay = fbCache(dayStart)
Else
On Error Resume Next
fbDay = rcp.FreeBusy(dayStart, slotMin, True) ' 当日0:00起点
On Error GoTo 0
If Len(fbDay) = 0 Then allFree(iSlot) = False: GoTo NextSlot
fbCache.Add dayStart, fbDay
End If
Dim pos As Long: pos = (DateDiff("n", dayStart, slotStart) \ slotMin) + 1
If pos < 1 Or pos > Len(fbDay) Then
allFree(iSlot) = False
Else
Dim ch As String: ch = Mid$(fbDay, pos, 1)
If Not IsCharFree(ch, treatTentative) Then allFree(iSlot) = False
End If
End If
NextSlot:
Next iSlot
Next i
' 連続区間
Dim ranges As Collection: Set ranges = New Collection
Dim runStart As Long: runStart = 0
For j = 1 To nSlots
If allFree(j) Then
If runStart = 0 Then runStart = j
ElseIf runStart > 0 Then
TryAddRange ranges, runStart, j - 1, minSlots: runStart = 0
End If
Next j
If runStart > 0 Then TryAddRange ranges, runStart, nSlots, minSlots
' 表示
Dim lst As Object: Set lst = frm.Controls("lstResults")
lst.Clear
If ranges.Count = 0 Then
lst.AddItem "条件を満たす共通空き時間は見つかりませんでした。"
Else
Dim dayDict As Object: Set dayDict = CreateObject("Scripting.Dictionary")
Dim dayOrder As Collection: Set dayOrder = New Collection
Dim it As Variant
For Each it In ranges
Dim sIdx As Long, eIdx As Long
sIdx = it(0): eIdx = it(1)
Dim sTime As Date, eTime As Date
sTime = DateAdd("n", (sIdx - 1) * slotMin, startDt)
eTime = DateAdd("n", eIdx * slotMin, startDt)
Dim dKey As Date: dKey = DateSerial(Year(sTime), Month(sTime), Day(sTime))
Dim seg As String: seg = Format(sTime, "HH:nn") & " ~ " & Format(eTime, "HH:nn")
If Not dayDict.Exists(dKey) Then
dayDict.Add dKey, seg: dayOrder.Add dKey
Else
dayDict(dKey) = dayDict(dKey) & "、 " & seg
End If
Next it
Dim k As Variant
For Each k In dayOrder
lst.AddItem Format(k, "yyyy/mm/dd") & " (" & WeekdayJpAbbrev(k) & ") " & dayDict(k)
Next k
End If
Exit Sub
EH:
MsgBox "抽出中エラー: " & Err.Description, vbExclamation
End Sub
Public Sub CopyResults(frm As Object)
Dim lst As Object: Set lst = frm.Controls("lstResults")
Dim s As String, i As Long
For i = 0 To lst.ListCount - 1
s = s & lst.List(i) & vbCrLf
Next
If Len(s) = 0 Then s = "(結果なし)"
With CreateObject("Forms.DataObject")
.SetText s: .PutInClipboard
End With
MsgBox "結果をコピーしました。", vbInformation
End Sub
Public Sub CreateMailFromResults(frm As Object)
Dim mail As Outlook.MailItem: Set mail = Application.CreateItem(olMailItem)
Dim hdr As String
hdr = "参加者: " & IIf(mRecips Is Nothing, "(未選択)", RecipientsToString(mRecips)) & vbCrLf
hdr = hdr & "期間: " & frm.Controls("txtStart").Value & " 〜 " & frm.Controls("txtEnd").Value & vbCrLf
hdr = hdr & "粒度(分): " & frm.Controls("cboSlot").Value & ", 会議(分): " & frm.Controls("txtDuration").Value & vbCrLf
hdr = hdr & "仮の予定(1): " & IIf(frm.Controls("chkTentative").Value, "空き扱い", "空き扱いしない") & vbCrLf
hdr = hdr & "営業時間: " & Format(TimeSerial(BUSINESS_START_HOUR, BUSINESS_START_MIN, 0), "HH:nn") & " 〜 " & Format(TimeSerial(BUSINESS_END_HOUR, BUSINESS_END_MIN, 0), "HH:nn") & vbCrLf
hdr = hdr & "土日除外: " & IIf(frm.Controls("chkExcludeWeekends").Value, "する", "しない") & vbCrLf
hdr = hdr & "昼休み除外(12:00–13:00): " & IIf(frm.Controls("chkExcludeLunch").Value, "する", "しない") & vbCrLf
hdr = hdr & "祝日除外: " & IIf(frm.Controls("chkExcludeHolidays").Value, "する", "しない") & vbCrLf
hdr = hdr & String(40, "-") & vbCrLf
Dim lst As Object: Set lst = frm.Controls("lstResults")
Dim body As String, i As Long
For i = 0 To lst.ListCount - 1: body = body & lst.List(i) & vbCrLf: Next
If Len(body) = 0 Then body = "(結果なし)"
mail.Subject = "共通空き時間の抽出結果"
mail.Body = "【共通空き時間の抽出結果】" & vbCrLf & hdr & body
mail.Display
End Sub
' ──────────────────────────────
' 3) フォールバック（フォーム不可時）
' ──────────────────────────────
Private Sub FindCommonFreeTimes_Fallback()
Dim ns As Outlook.NameSpace: Set ns = Application.Session
Dim snd As Outlook.SelectNamesDialog: Set snd = ns.GetSelectNamesDialog
With snd
.Caption = "参加者を選択"
.NumberOfRecipientSelectors = OlRecipientSelectors.olShowTo
.ToLabel = "参加者"
.ForceResolution = True
.AllowMultipleSelection = True
If Not .Display Then Exit Sub
End With
Set mRecips = snd.Recipients
If mRecips Is Nothing Or mRecips.Count = 0 Then MsgBox "参加者未選択", vbExclamation: Exit Sub
Dim startDt As Date, endDt As Date, slotMin As Long, needMin As Long
If Not TryParseDate(InputBox("開始日時（例: 2025/8/18 09:00）", "開始", Format(Date + TimeSerial(9, 0, 0), "yyyy/m/d HH:nn")), startDt) Then Exit Sub
If Not TryParseDate(InputBox("終了日時（例: 2025/8/25 18:00）", "終了", Format(DateAdd("d", 7, Date) + TimeSerial(18, 0, 0), "yyyy/m/d HH:nn")), endDt) Then Exit Sub
If endDt <= startDt Then MsgBox "終了は開始より後に。", vbExclamation: Exit Sub
Dim s As String: s = InputBox("粒度（分）5/10/15/30/60", "粒度", "30"): If Len(s) = 0 Or Not IsNumeric(s) Then Exit Sub
slotMin = CLng(s): If slotMin <= 0 Or 1440 Mod slotMin <> 0 Then MsgBox "粒度不正", vbExclamation: Exit Sub
s = InputBox("会議時間（分）", "会議分", "60"): If Len(s) = 0 Or Not IsNumeric(s) Then Exit Sub
needMin = CLng(s): If needMin <= 0 Then MsgBox "会議分不正", vbExclamation: Exit Sub
Dim treatTentative As Boolean: treatTentative = (MsgBox("仮の予定(1)を空き扱いにしますか？", vbYesNo + vbQuestion) = vbYes)
Dim excludeWeekends As Boolean: excludeWeekends = (MsgBox("土日を除外しますか？", vbYesNo + vbQuestion) = vbYes)
Dim excludeHolidays As Boolean: excludeHolidays = (MsgBox("祝日を除外しますか？", vbYesNo + vbQuestion) = vbYes)
Dim excludeLunch As Boolean: excludeLunch = (MsgBox("昼休み(12:00–13:00)を除外しますか？", vbYesNo + vbQuestion) = vbYes)
Dim includeMe As Boolean: includeMe = (MsgBox("自分も判定対象に含めますか？", vbYesNo + vbQuestion) = vbYes)
If includeMe Then EnsureCurrentUserIncluded ns, mRecips
' 抽出本体（フォーム版と同じ）
Dim totalMin As Long, nSlots As Long, minSlots As Long
totalMin = DateDiff("n", startDt, endDt)
nSlots = totalMin \ slotMin
If nSlots <= 0 Then MsgBox "期間が短すぎます。", vbExclamation: Exit Sub
minSlots = (needMin + slotMin - 1) \ slotMin
Dim allFree() As Boolean
ReDim allFree(1 To nSlots)
Dim j As Long: For j = 1 To nSlots: allFree(j) = True: Next
Dim i As Long, iSlot As Long
For i = 1 To mRecips.Count
Dim rcp As Outlook.Recipient: Set rcp = mRecips(i)
If Not rcp.Resolve Then MsgBox "解決できない参加者: " & rcp.Name, vbExclamation: Exit Sub
Dim fbCache As Object: Set fbCache = CreateObject("Scripting.Dictionary")
For iSlot = 1 To nSlots
Dim slotStart As Date, slotEnd As Date
slotStart = DateAdd("n", (iSlot - 1) * slotMin, startDt)
slotEnd = DateAdd("n", iSlot * slotMin, startDt)
If Not IsSlotBusinessEligible(slotStart, slotEnd, excludeWeekends, excludeHolidays, excludeLunch) Then
allFree(iSlot) = False
Else
Dim dayStart As Date: dayStart = DateSerial(Year(slotStart), Month(slotStart), Day(slotStart))
Dim fbDay As String
If fbCache.Exists(dayStart) Then
fbDay = fbCache(dayStart)
Else
On Error Resume Next
fbDay = rcp.FreeBusy(dayStart, slotMin, True)
On Error GoTo 0
If Len(fbDay) = 0 Then allFree(iSlot) = False: GoTo NextSlot2
fbCache.Add dayStart, fbDay
End If
Dim pos As Long: pos = (DateDiff("n", dayStart, slotStart) \ slotMin) + 1
If pos < 1 Or pos > Len(fbDay) Then
allFree(iSlot) = False
Else
Dim ch As String: ch = Mid$(fbDay, pos, 1)
If Not IsCharFree(ch, treatTentative) Then allFree(iSlot) = False
End If
End If
NextSlot2:
Next iSlot
Next i
Dim ranges As Collection: Set ranges = New Collection
Dim runStart As Long: runStart = 0
For j = 1 To nSlots
If allFree(j) Then
If runStart = 0 Then runStart = j
ElseIf runStart > 0 Then
TryAddRange ranges, runStart, j - 1, minSlots: runStart = 0
End If
Next j
If runStart > 0 Then TryAddRange ranges, runStart, nSlots, minSlots
Dim mail As Outlook.MailItem: Set mail = Application.CreateItem(olMailItem)
Dim body As String
body = "【共通空き時間の抽出結果】" & vbCrLf & _
"参加者: " & RecipientsToString(mRecips) & vbCrLf & _
"期間: " & Format(startDt, "yyyy/mm/dd HH:nn") & " 〜 " & Format(endDt, "yyyy/mm/dd HH:nn") & vbCrLf & _
"粒度: " & slotMin & " 分/スロット, 会議: " & needMin & " 分" & vbCrLf & _
"仮の予定(1): " & IIf(treatTentative, "空き扱い", "空き扱いしない") & vbCrLf & _
"営業時間: " & Format(TimeSerial(BUSINESS_START_HOUR, BUSINESS_START_MIN, 0), "HH:nn") & " 〜 " & Format(TimeSerial(BUSINESS_END_HOUR, BUSINESS_END_MIN, 0), "HH:nn") & vbCrLf & _
"土日除外: " & IIf(excludeWeekends, "する", "しない") & vbCrLf & _
"祝日除外: " & IIf(excludeHolidays, "する", "しない") & vbCrLf & _
"昼休み除外: " & IIf(excludeLunch, "する", "しない") & vbCrLf & _
String(40, "-") & vbCrLf
If ranges.Count = 0 Then
body = body & "条件を満たす共通空き時間は見つかりませんでした。" & vbCrLf
Else
Dim dayDict As Object: Set dayDict = CreateObject("Scripting.Dictionary")
Dim dayOrder As Collection: Set dayOrder = New Collection
Dim it As Variant
For Each it In ranges
Dim sIdx As Long, eIdx As Long
sIdx = it(0): eIdx = it(1)
Dim sTime As Date, eTime As Date
sTime = DateAdd("n", (sIdx - 1) * slotMin, startDt)
eTime = DateAdd("n", eIdx * slotMin, startDt)
Dim key As Date: key = DateSerial(Year(sTime), Month(sTime), Day(sTime))
Dim seg As String: seg = Format(sTime, "HH:nn") & " ~ " & Format(eTime, "HH:nn")
If Not dayDict.Exists(key) Then
dayDict.Add key, seg: dayOrder.Add key
Else
dayDict(key) = dayDict(key) & "、 " & seg
End If
Next it
Dim k As Variant
For Each k In dayOrder
body = body & Format(k, "yyyy/mm/dd") & " (" & WeekdayJpAbbrev(k) & ") " & dayDict(k) & vbCrLf
Next k
End If
mail.Subject = "共通空き時間の抽出結果"
mail.Body = body
mail.Display
End Sub
' ──────────────────────────────
' 共通ユーティリティ
' ──────────────────────────────
Private Function TryParseDate(ByVal s As String, ByRef dt As Date) As Boolean
On Error Resume Next
dt = CDate(s)
TryParseDate = (Err.Number = 0)
Err.Clear
End Function
Private Function IsCharFree(ByVal ch As String, ByVal treatTentative As Boolean) As Boolean
If ch = "0" Then
IsCharFree = True
ElseIf treatTentative And ch = "1" Then
IsCharFree = True
Else
IsCharFree = False
End If
End Function
' スロットが有効（営業時間/土日/祝日/昼休み）
Private Function IsSlotBusinessEligible( _
ByVal slotStart As Date, ByVal slotEnd As Date, _
ByVal excludeWeekends As Boolean, _
ByVal excludeHolidays As Boolean, _
ByVal excludeLunch As Boolean) As Boolean
Dim d As Date: d = DateSerial(Year(slotStart), Month(slotStart), Day(slotStart))
If excludeWeekends Then
Dim wd As VbDayOfWeek: wd = Weekday(d, vbSunday)
If wd = vbSaturday Or wd = vbSunday Then IsSlotBusinessEligible = False: Exit Function
End If
If excludeHolidays Then
If IsJapaneseHoliday(d) Then IsSlotBusinessEligible = False: Exit Function
End If
Dim businessStart As Date, businessEnd As Date
businessStart = d + TimeSerial(BUSINESS_START_HOUR, BUSINESS_START_MIN, 0)
businessEnd = d + TimeSerial(BUSINESS_END_HOUR, BUSINESS_END_MIN, 0)
If Not (slotStart >= businessStart And slotEnd <= businessEnd) Then
IsSlotBusinessEligible = False: Exit Function
End If
If excludeLunch Then
Dim lunchStart As Date, lunchEnd As Date
lunchStart = d + TimeSerial(12, 0, 0)
lunchEnd = d + TimeSerial(13, 0, 0)
If (slotStart < lunchEnd) And (slotEnd > lunchStart) Then
IsSlotBusinessEligible = False: Exit Function
End If
End If
IsSlotBusinessEligible = True
End Function
Public Function WeekdayJpAbbrev(ByVal d As Date) As String
Select Case Weekday(d, vbSunday)
Case vbSunday: WeekdayJpAbbrev = "日"
Case vbMonday: WeekdayJpAbbrev = "月"
Case vbTuesday: WeekdayJpAbbrev = "火"
Case vbWednesday: WeekdayJpAbbrev = "水"
Case vbThursday: WeekdayJpAbbrev = "木"
Case vbFriday: WeekdayJpAbbrev = "金"
Case vbSaturday: WeekdayJpAbbrev = "土"
End Select
End Function
Private Function RecipientsToString(ByVal recips As Outlook.Recipients) As String
Dim i As Long, t As String
For i = 1 To recips.Count
If Len(t) > 0 Then t = t & "; "
t = t & recips(i).Name
Next i
RecipientsToString = t
End Function
Private Sub EnsureCurrentUserIncluded(ByVal ns As Outlook.NameSpace, ByRef recips As Outlook.Recipients)
On Error Resume Next
Dim curName As String: curName = ns.CurrentUser.Name
On Error GoTo 0
If Len(curName) = 0 Then Exit Sub
Dim i As Long
For i = 1 To recips.Count
If StrComp(recips(i).Name, curName, vbTextCompare) = 0 Then Exit Sub
Next i
Dim r As Outlook.Recipient
Set r = recips.Add(curName)
If Not r Is Nothing Then If r.Resolve = False Then r.Delete
End Sub
Private Sub TryAddRange(ByRef ranges As Collection, ByVal sIdx As Long, ByVal eIdx As Long, ByVal minSlots As Long)
If eIdx >= sIdx Then
If (eIdx - sIdx + 1) >= minSlots Then
Dim pair(1) As Long: pair(0) = sIdx: pair(1) = eIdx
ranges.Add pair
End If
End If
End Sub
' ──────────────────────────────
' 祝日（固定/ハッピーマンデー/春秋分/国民の休日/振替/五輪特例）
' ──────────────────────────────
Private Function IsJapaneseHoliday(ByVal d As Date) As Boolean
Dim y As Long: y = Year(d)
Dim dict As Object: Set dict = GetHolidayDictForYear(y)
IsJapaneseHoliday = dict.Exists(DateSerial(Year(d), Month(d), Day(d)))
End Function
Private Function GetHolidayDictForYear(ByVal y As Long) As Object
If mHolidayCache Is Nothing Then Set mHolidayCache = CreateObject("Scripting.Dictionary")
If Not mHolidayCache.Exists(y) Then mHolidayCache.Add y, BuildJapaneseHolidays(y)
Set GetHolidayDictForYear = mHolidayCache(y)
End Function
Private Function BuildJapaneseHolidays(ByVal y As Long) As Object
Dim H As Object: Set H = CreateObject("Scripting.Dictionary")
' 固定祝日
AddHoliday H, DateSerial(y, 1, 1)
AddHoliday H, DateSerial(y, 2, 11)
If y >= 2020 Then AddHoliday H, DateSerial(y, 2, 23) ' 天皇誕生日(令和)
AddHoliday H, DateSerial(y, 4, 29)
AddHoliday H, DateSerial(y, 5, 3)
AddHoliday H, DateSerial(y, 5, 4)
AddHoliday H, DateSerial(y, 5, 5)
AddHoliday H, DateSerial(y, 8, 11)
AddHoliday H, DateSerial(y, 11, 3)
AddHoliday H, DateSerial(y, 11, 23)
' ハッピーマンデー
AddHoliday H, NthWeekdayOfMonth(y, 1, vbMonday, 2) ' 成人の日
AddHoliday H, NthWeekdayOfMonth(y, 7, vbMonday, 3) ' 海の日
AddHoliday H, NthWeekdayOfMonth(y, 9, vbMonday, 3) ' 敬老の日
AddHoliday H, NthWeekdayOfMonth(y, 10, vbMonday, 2) ' スポーツの日
' 春分・秋分（近似）
Dim shun As Integer, shu As Integer
shun = Int(20.8431 + 0.242194 * (y - 1980)) - Int((y - 1980) \ 4)
AddHoliday H, DateSerial(y, 3, shun)
shu = Int(23.2488 + 0.242194 * (y - 1980)) - Int((y - 1980) \ 4)
AddHoliday H, DateSerial(y, 9, shu)
' 五輪特例 2020/2021
If y = 2020 Then
RemoveHoliday H, NthWeekdayOfMonth(y, 7, vbMonday, 3)
RemoveHoliday H, NthWeekdayOfMonth(y, 10, vbMonday, 2)
RemoveHoliday H, DateSerial(y, 8, 11)
AddHoliday H, DateSerial(y, 7, 23)
AddHoliday H, DateSerial(y, 7, 24)
AddHoliday H, DateSerial(y, 8, 10)
ElseIf y = 2021 Then
RemoveHoliday H, NthWeekdayOfMonth(y, 7, vbMonday, 3)
RemoveHoliday H, NthWeekdayOfMonth(y, 10, vbMonday, 2)
RemoveHoliday H, DateSerial(y, 8, 11)
AddHoliday H, DateSerial(y, 7, 22)
AddHoliday H, DateSerial(y, 7, 23)
AddHoliday H, DateSerial(y, 8, 8)
' 8/9 は振替処理で付与
End If
' 国民の休日（前後が祝日の平日）
Dim dt As Date
For dt = DateSerial(y, 1, 2) To DateSerial(y, 12, 30)
If Not H.Exists(dt) Then
If IsWeekday(dt) And H.Exists(DateAdd("d", -1, dt)) And H.Exists(DateAdd("d", 1, dt)) Then
AddHoliday H, dt
End If
End If
Next dt
' 振替休日（祝日が日曜）
Dim keys As Variant: keys = H.Keys
Dim i As Long
For i = LBound(keys) To UBound(keys)
dt = keys(i)
If Weekday(dt, vbSunday) = vbSunday Then
Dim subDay As Date: subDay = DateAdd("d", 1, dt)
Do While Not IsWeekday(subDay) Or H.Exists(subDay)
subDay = DateAdd("d", 1, subDay)
If Year(subDay) <> y Then Exit Do
Loop
If Year(subDay) = y Then AddHoliday H, subDay
End If
Next i
Set BuildJapaneseHolidays = H
End Function
Private Function IsWeekday(ByVal d As Date) As Boolean
Dim wd As VbDayOfWeek: wd = Weekday(d, vbSunday)
IsWeekday = (wd >= vbMonday And wd <= vbFriday)
End Function
Private Function NthWeekdayOfMonth(ByVal y As Long, ByVal m As Long, ByVal vbWDay As VbDayOfWeek, ByVal n As Long) As Date
Dim first As Date: first = DateSerial(y, m, 1)
Dim offset As Long: offset = (vbWDay - Weekday(first, vbSunday) + 7) Mod 7
NthWeekdayOfMonth = DateSerial(y, m, 1 + offset + 7 * (n - 1))
End Function
Private Sub AddHoliday(ByRef dict As Object, ByVal d As Date)
d = DateSerial(Year(d), Month(d), Day(d))
If Not dict.Exists(d) Then dict.Add d, True
End Sub
Private Sub RemoveHoliday(ByRef dict As Object, ByVal d As Date)
d = DateSerial(Year(d), Month(d), Day(d))
If dict.Exists(d) Then dict.Remove d
End Sub
Outlook上で指定したユーザー、指定した期間での共通の空き時間を抽出するコード
Last updated at Posted at 2025-08-18
Register as a new user and use Qiita more conveniently
- You get articles that match your needs
- You can efficiently read back useful information
- You can use dark theme