furyutei/0.README.md

## 0.README.md

      
    Raw
  

              0.README.md
            
          
    [Excel][VBA] Excel用DatePicker

Excelで、カレンダーから選択してセルに日付を入力できるようにするためのアドインです。

  
    VBA.02.mp4
    
  
※元ネタはこちら

例によって興味本位でやってみただけなので、実用性には疑問符が付きます
ソースコードを見ていただけるとわかりますが、すこしトリッキーなことをやっています（とりあえずインターネットへのアクセスに制限があるとうまく動きません）
「セルのすぐ隣にUserFormを表示する」という一見簡単なことも実際やってみるとかなりややこしいみたいです……この部分については、もしかすると参考になるかも……？
ほとんどテストをしていないので、うまく動かなくてもご容赦を……特にマルチディスプレイ環境などでは正常に動作しない確率が高いです（アドバイスは歓迎です）

■ダウンロード

こちらからダウンロードしてください

[すべてダウンロード]を押してZIPファイルとしてダウンロードします。
ダウンロードされたZIPファイルはそのままではセキュリティの関係でうまく動作しないため、ファイルのプロパティより以下のように「☑ 許可する」にチェックした上で解凍してください。

■インストール


起動中のエクセルがあればすべて終了しておく
「インストール」フォルダにある「Install.vbs」を実行して指示に従う
エクセルを起動し、ファイル＞オプション＞アドインにて、「DatePicker」アドインを有効にしておく

■動作

セルを選択した状態でリボンのDatePickerタブを開いて「DatePickerを開く」を押すと、カレンダーが表示され、日付を選択すれば選択しているセルに入力されます。

※起動はCtrl+Shift+Dでも出来ます。
■アンインストール


「インストール」フォルダにある「Uninstall.vbs」を実行して指示に従う

■ライセンス


The MIT license
Copyright (c) 2023 風柳(furyu)

■免責事項

動作保証は一切ありません。ご利用の際には全て自己責任でお願いします。

不具合があったり、使用した結果等により万一何らかの損害を被ったりした場合でも、作者は一切関知いたしませんので、悪しからずご了承願います。
■ソースコードについて

このページに貼り付けてあるソースコードは個人的に後で参照しやすいようにしてあるだけです。

また、最新版ではない可能性もありますのでご注意ください。
■関連


[Excel][VBA] ユーザーフォームをアクティブセルの右横に表示する実装例


## ClsDomEventUtil.vba
Option Explicit

Const DataVbaIdName = "data-vbaid"

Private WithEvents TargetBrowser As WebBrowser

Private NextElementId
Private EventCollectionDict As Dictionary

Public Function Init(Browser)
    Set TargetBrowser = Browser
    NextElementId = CLng(1)
    Set EventCollectionDict = New Dictionary
    Set Init = Me
End Function

Public Function AddEventHandler(DomElement, EventType, CallbackFunc, Optional CallObject, Optional UseCapture As Boolean = False, Optional StopPropagation As Boolean = False, Optional PreventDefault As Boolean = False)
    With TargetBrowser.Document
        ' イベント対象となる要素に一意の番号（VbaId）を付与
        Dim VbaId: VbaId = DomElement.getAttribute(DataVbaIdName)
        If IsNull(VbaId) Then
            VbaId = NextElementId
            NextElementId = NextElementId + 1
            Call DomElement.setAttribute(DataVbaIdName, VbaId)
        End If
        VbaId = CStr(VbaId)

        ' 指定されたイベント情報をVbaIdをkeyとして対応するCollectionに追加
        Dim EventInfo As Dictionary: Set EventInfo = New Dictionary
        With EventInfo
            Call .Add("DomElement", DomElement)
            Call .Add("EventType", EventType)
            Call .Add("CallbackFunc", CallbackFunc)
            Call .Add("CallObject", IIf(IsMissing(CallObject), Nothing, CallObject))
            Call .Add("UseCapture", UseCapture)
            Call .Add("StopPropagation", StopPropagation)
            Call .Add("PreventDefault", PreventDefault)
        End With
        If Not EventCollectionDict.Exists(VbaId) Then Call EventCollectionDict.Add(VbaId, New Collection)
        Call EventCollectionDict(VbaId).Add(EventInfo)

        ' ブラウザ上（JavaScript）にて、イベント対象となる要素にイベントハンドラを登録
        ' [TODO] イベントハンドラ登録時に document.querySelector() にて要素を特定する関係上、DomElement は予め document 下の DOM ツリー上になければならない
        '
        ' ※ EventType で指定されたイベントが発生すると、
        '   - event オブジェクトを自要素（[data-vbaid="<VbaId>"]）の lastEvent として保存
        '   - document.title を自要素の VbaId に書き換え
        '   が行われ、これにより VBAのTargetBrowser_TitleChangeプロシージャが呼び出される
        '
        Dim ElmScript: Set ElmScript = .createElement("script")
        Dim ScriptText

        If .documentMode < 9 Then
            ' [TODO] コールバックに渡される event において、IE8 以下だと event.type がセットされない模様→独自に .eventType を設定
            ScriptText = Join(Array( _
                "(function(elm){", _
                "elm.attachEvent('on" & EventType & "', function(event){", _
                "    event.eventType = '" & EventType & "'; elm.lastEvent = event;", _
                "    document.title = " & VbaId & ";", _
                "    return " & IIf(PreventDefault, "false", "true") & ";", _
                "});", _
                "})(document.querySelector('[" & DataVbaIdName & "=""" & VbaId & """]'));" _
            ), vbLf)
        Else
            ScriptText = Join(Array( _
                "document.querySelector('[" & DataVbaIdName & "=""" & VbaId & """]').addEventListener('" & EventType & "', function(event){", _
                "    " & IIf(StopPropagation, "event.stopPropagation();", ""), _
                "    " & IIf(PreventDefault, "event.preventDefault();", ""), _
                "    this.lastEvent = event;", _
                "    document.title = " & VbaId & ";", _
                "}, " & IIf(UseCapture, "true", "false") & ");" _
            ), vbLf)
        End If
        ElmScript.Text = ScriptText
        Call .body.appendChild(ElmScript)
    End With
    Set AddEventHandler = Me
End Function

' JavaScript での document.title の上書きに伴い呼び出される
Private Sub TargetBrowser_TitleChange(ByVal Text As String)
    Dim VbaId: VbaId = Text
    If Not EventCollectionDict.Exists(VbaId) Then Exit Sub

    Dim TargetElement

'    On Error Resume Next
'    Set TargetElement = TargetBrowser.Document.querySelector("[" & DataVbaIdName & "=""" & VbaId & """]")
'    ' [TODO] documentMode が 8 以下だと、WebBrowser コントロールの Document.querySelector が動作しない模様
'    If Err.Number <> 0 Then Exit Sub

    If Not EventCollectionDict.Exists(VbaId) Then Exit Sub

    Dim EventInfo
    For Each EventInfo In EventCollectionDict(VbaId)
        Set TargetElement = EventInfo("DomElement")
        Call Callback(TargetElement, EventInfo)
    Next
End Sub

Private Sub Callback(DomElement, EventInfo)
    Dim DomEvent: Set DomEvent = DomElement.lastEvent
    Dim EventType: EventType = EventInfo("EventType")

    If TargetBrowser.Document.documentMode < 9 Then
        ' [TODO] DomEvent.Type は IE8 以下だとセットされない模様→ JavaScript 側にて独自に DomEvent.eventType を設定するようにしてある
        If DomEvent.EventType <> EventType Then Exit Sub
    Else
        If DomEvent.Type <> EventType Then Exit Sub
    End If

    Dim CallbackFunc: CallbackFunc = EventInfo("CallbackFunc")
    Dim CallObject: Set CallObject = EventInfo("CallObject")

    If CallObject Is Nothing Then
        Call Application.Run(CallbackFunc, EventType, DomElement, DomEvent)
    Else
        Call CallByName(CallObject, CallbackFunc, VbMethod, EventType, DomElement, DomEvent)
    End If
End Sub

## FormDatePicker.vba
Option Explicit

Const WebBrowserNavigateError = 5001
Const WebBrowserTimeout = 5002

Private IsDocumentReady As Boolean
Private DomEventUtil As ClsDomEventUtil
Private CurrentTargetCell As Range
Private CurrentFirstWeekday As Integer

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    CurrentFirstWeekday = 1
    CommandButton1.Cancel = False ' 準備(Activate)完了までは閉じる(Esc)機能を無効化
End Sub

Private Sub UserForm_Activate()
    Dim CellDateString
    On Error Resume Next
    If CurrentTargetCell.Value <> "" Then
        CellDateString = Format(CDate(CurrentTargetCell.Value), "yyyy/mm/dd")
    End If
    On Error GoTo 0
    FormPage = "https://nazo.furyutei.com/vbaparts/datepicker.html?initdate=" & CellDateString & "&firstday=" & CStr(FirstWeekday)
    Dim InputElement: Set InputElement = WebBrowser1.Document.getElementById("target-date")
    Set DomEventUtil = New ClsDomEventUtil
    Call DomEventUtil.Init(WebBrowser1).AddEventHandler(InputElement, "change", "EventCallback", Me)
    CommandButton1.Cancel = True
End Sub

Public Sub EventCallback(EventType, DomElement, DomEvent)
'    Debug.Print DomEvent.Type & ":" & DomElement.Value
    If Not (CurrentTargetCell Is Nothing) Then CurrentTargetCell.Value = CDate(DomElement.Value)
End Sub

Public Property Get Sunday() As Integer: Sunday = 0: End Property
Public Property Get Monday() As Integer: Monday = 1: End Property
Public Property Get Tuesday() As Integer: Tuesday = 2: End Property
Public Property Get Wednesday() As Integer: Wednesday = 3: End Property
Public Property Get Thursday() As Integer: Thursday = 4: End Property
Public Property Get Friday() As Integer: Friday = 5: End Property
Public Property Get Saturday() As Integer: Saturday = 6: End Property

Public Property Set TargetCell(SpecifiedCell As Range)
    Set CurrentTargetCell = SpecifiedCell
End Property

Public Property Get TargetCell() As Range
    Set TargetCell = CurrentTargetCell
End Property

Public Property Let FirstWeekday(DayNumber As Integer)
    If DayNumber < 0 Or 6 < DayNumber Then
        DayNumber = 1
    End If
    CurrentFirstWeekday = DayNumber
End Property

Public Property Get FirstWeekday() As Integer
    FirstWeekday = CurrentFirstWeekday
End Property

Private Property Let FormPage(URL)
    Dim TimeoutTime: TimeoutTime = Now() + TimeValue("00:00:30")
    IsDocumentReady = False
    With WebBrowser1
        Call .Navigate(URL)
        Do While Not IsDocumentReady
            If TimeoutTime <= Now() Then Call Err.Raise(WebBrowserTimeout, Description:="タイムアウトしました")
            DoEvents
        Loop
    End With
End Property

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    IsDocumentReady = True
End Sub

Private Sub WebBrowser1_NavigateError(ByVal pDisp As Object, URL As Variant, frame As Variant, StatusCode As Variant, Cancel As Boolean)
    Call Err.Raise(WebBrowserNavigateError, Description:="ページ読み込み失敗" & vbLf & vbLf & URL & vbLf & vbLf & "実行時エラー: " & StatusCode & " (" & Hex(StatusCode) & ")")
End Sub

## ModDatePicker.vba
Option Explicit

Sub DatePicker()
    Dim TargetCell As Range: Set TargetCell = ActiveCell
    Dim TargetWindow As Window: Set TargetWindow = ActiveWindow
    Dim TargetDisplayPosition As ScreenPosition: TargetDisplayPosition = ConvertToScreenPosition(TargetCell.Top, TargetCell.Left)
    Dim TargetDisplayDotsPerPoint As DotsPerPoint: TargetDisplayDotsPerPoint = GetDisplayDotsPerPoint()
    Dim WindowScale As Double: WindowScale = TargetWindow.Zoom / 100#
    Dim FormTopOffset As Double: FormTopOffset = 0 * WindowScale
    Dim FormLeftOffset As Double: FormLeftOffset = TargetCell.MergeArea.Width * WindowScale
    Dim FormTop As Double: FormTop = (TargetDisplayPosition.y / TargetDisplayDotsPerPoint.y) + FormTopOffset
    Dim FormLeft As Double: FormLeft = (TargetDisplayPosition.x / TargetDisplayDotsPerPoint.x) + FormLeftOffset
    Dim TargetDatePicker As FormDatePicker: Set TargetDatePicker = FormDatePicker
    Call SetUserFormPosition(TargetDatePicker, FormTop, FormLeft)
    With TargetDatePicker
        Set .TargetCell = TargetCell ' 日付取得対象のセル指定
        .FirstWeekday = .Monday ' カレンダー左端の曜日指定
        Call .Show(vbModal)
    End With
End Sub

## ModRibbon.vba
Option Explicit

Public Sub Rbn_customUI_onLoad(ribbon As IRibbonUI)
' Code for onLoad callback. Ribbon control customUI

End Sub

Public Sub Rbn_DatePicker_Calendar_OpenDatePicker_onAction(control As IRibbonControl)
' Code for onAction callback. Ribbon control button
    Call DatePicker
End Sub

## ModScreenCoordinates.vba
Option Explicit

'【TODO】
' - ActiveWindowが解像度が違うモニタ(デスクトップ)間にまたがっている場合にはUserFormの表示や位置が崩れてしまう(画面端にスナップした場合等にも発生)

' 【覚書】
' - 環境によってはActiveCellがActiveWindowの右の方にあるとUserFormの表示位置が左によってきてしまう場合がある（PointsToScreenPixelsXが正しい値を返さない模様）
'   → Microsoft 365のエクセルにて「ファイル＞オプション＞設定＞全般＞ユーザー インターフェイスのオプション＞複数ディスプレイを使用する場合」で
'      ○ 表示を優先した最適化 (アプリケーションの再起動が必要)
'   　 を選択していると、マルチディスプレイ環境にて発生する場合があることが判明（https://twitter.com/furyutei/status/1645413942582448129）
'      この場合には
'      ○  互換性に対応した最適化
'      に変更後、再起動すれば、改善される模様

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" (ByVal pacc As Object, phwnd As LongPtr) As LongPtr

Type ScreenPosition
    x As Double
    y As Double
End Type

Type DotsPerPoint
    x As Double
    y As Double
End Type

Type CoordinateFactor
    x As Double
    y As Double
End Type

Function ConvertToScreenPosition(TargetTop, TargetLeft, Optional TargetWindow As Window) As ScreenPosition
    If TargetWindow Is Nothing Then Set TargetWindow = ActiveWindow
    Dim Result As ScreenPosition
    Dim PaneIndex As Long, WorkPane As Pane, WorkRange As Range
    For PaneIndex = 1 To TargetWindow.Panes.Count
        Set WorkPane = TargetWindow.Panes(PaneIndex)
        With WorkPane.VisibleRange
            If _
                ((.Top <= TargetTop) And (TargetTop < .Top + .Height)) And _
                ((.Left <= TargetLeft) And (TargetLeft < .Left + .Width)) _
            Then
                Result.x = WorkPane.PointsToScreenPixelsX(TargetLeft)
                Result.y = WorkPane.PointsToScreenPixelsY(TargetTop)
                Exit For
            End If
        End With
    Next
    ConvertToScreenPosition = Result
End Function

Function GetDisplayDotsPerPoint(Optional TargetWindow As Window) As DotsPerPoint
    If TargetWindow Is Nothing Then Set TargetWindow = ActiveWindow
    Dim Result As DotsPerPoint
    Dim WindowRect As RECT
    If Application.Version < 15# Then
        ' Excel 2010以前のバージョンだとWindowオブジェクトにはhWndプロパティがない（SDIのためと思われる）
        ' →代わりにApplication.hWndを使用
        Call GetWindowRect(Application.hWnd, WindowRect)
    Else
        Call GetWindowRect(TargetWindow.hWnd, WindowRect)
    End If
    With WindowRect
        Result.x = (.Bottom - .Top) / TargetWindow.Height
        Result.y = (.Right - .Left) / TargetWindow.Width
    End With
    GetDisplayDotsPerPoint = Result
End Function

Function SetUserFormPosition(TargetForm, Top As Double, Left As Double, Optional Calibration As Boolean = True) As CoordinateFactor
    '【覚書】
    '   UserFormの表示位置(.Top/.Left)は画面左上を基点として(ポイント数で)指定するはずだが、何故か想定する位置より右下にずれてしまうことがある
    '   その場合は経験上、表示したい位置(ポイント)の値にある係数（高さと幅(.Height/.Width)の設定値と実測値の比率・例:14/15=0.9333…）を掛けるとちょうどよい位置となる模様
    Dim Result As CoordinateFactor
    With TargetForm
        .StartUpPosition = 0 ' 0:Manual, 1:CenterOwner, 2:CenterScreen, 3:WindowsDefault
        .Top = Top
        .Left = Left
        If Not Calibration Then
            Result.y = 1#: Result.x = 1#
            GoTo CLEANUP
        End If
        Dim Height As Double: Height = .Height
        Dim Width As Double: Width = .Width
        Dim FormhWnd As LongPtr: Call WindowFromObject(TargetForm, FormhWnd)
        Dim FormRect As RECT: Call GetWindowRect(FormhWnd, FormRect)
        Dim TargetDisplayDotsPerPoint As DotsPerPoint: TargetDisplayDotsPerPoint = GetDisplayDotsPerPoint()
        Dim ActualHeight As Double: ActualHeight = (FormRect.Bottom - FormRect.Top) / TargetDisplayDotsPerPoint.y
        Dim ActualWidth As Double: ActualWidth = (FormRect.Right - FormRect.Left) / TargetDisplayDotsPerPoint.x
        Dim FormCoordinateFactorY As Double: FormCoordinateFactorY = Height / ActualHeight
        Dim FormCoordinateFactorX As Double: FormCoordinateFactorX = Width / ActualWidth
        .Top = Top * FormCoordinateFactorY
        .Left = Left * FormCoordinateFactorX
        Result.y = FormCoordinateFactorY
        Result.x = FormCoordinateFactorX
    End With

CLEANUP:
    SetUserFormPosition = Result
End Function
	Option Explicit

	Const DataVbaIdName = "data-vbaid"

	Private WithEvents TargetBrowser As WebBrowser

	Private NextElementId
	Private EventCollectionDict As Dictionary

	Public Function Init(Browser)
	Set TargetBrowser = Browser
	NextElementId = CLng(1)
	Set EventCollectionDict = New Dictionary
	Set Init = Me
	End Function

	Public Function AddEventHandler(DomElement, EventType, CallbackFunc, Optional CallObject, Optional UseCapture As Boolean = False, Optional StopPropagation As Boolean = False, Optional PreventDefault As Boolean = False)
	With TargetBrowser.Document
	' イベント対象となる要素に一意の番号（VbaId）を付与
	Dim VbaId: VbaId = DomElement.getAttribute(DataVbaIdName)
	If IsNull(VbaId) Then
	VbaId = NextElementId
	NextElementId = NextElementId + 1
	Call DomElement.setAttribute(DataVbaIdName, VbaId)
	End If
	VbaId = CStr(VbaId)

	' 指定されたイベント情報をVbaIdをkeyとして対応するCollectionに追加
	Dim EventInfo As Dictionary: Set EventInfo = New Dictionary
	With EventInfo
	Call .Add("DomElement", DomElement)
	Call .Add("EventType", EventType)
	Call .Add("CallbackFunc", CallbackFunc)
	Call .Add("CallObject", IIf(IsMissing(CallObject), Nothing, CallObject))
	Call .Add("UseCapture", UseCapture)
	Call .Add("StopPropagation", StopPropagation)
	Call .Add("PreventDefault", PreventDefault)
	End With
	If Not EventCollectionDict.Exists(VbaId) Then Call EventCollectionDict.Add(VbaId, New Collection)
	Call EventCollectionDict(VbaId).Add(EventInfo)

	' ブラウザ上（JavaScript）にて、イベント対象となる要素にイベントハンドラを登録
	' [TODO] イベントハンドラ登録時に document.querySelector() にて要素を特定する関係上、DomElement は予め document 下の DOM ツリー上になければならない
	'
	' ※ EventType で指定されたイベントが発生すると、
	' - event オブジェクトを自要素（[data-vbaid="<VbaId>"]）の lastEvent として保存
	' - document.title を自要素の VbaId に書き換え
	' が行われ、これにより VBAのTargetBrowser_TitleChangeプロシージャが呼び出される
	'
	Dim ElmScript: Set ElmScript = .createElement("script")
	Dim ScriptText

	If .documentMode < 9 Then
	' [TODO] コールバックに渡される event において、IE8 以下だと event.type がセットされない模様→独自に .eventType を設定
	ScriptText = Join(Array( _
	"(function(elm){", _
	"elm.attachEvent('on" & EventType & "', function(event){", _
	" event.eventType = '" & EventType & "'; elm.lastEvent = event;", _
	" document.title = " & VbaId & ";", _
	" return " & IIf(PreventDefault, "false", "true") & ";", _
	"});", _
	"})(document.querySelector('[" & DataVbaIdName & "=""" & VbaId & """]'));" _
	), vbLf)
	Else
	ScriptText = Join(Array( _
	"document.querySelector('[" & DataVbaIdName & "=""" & VbaId & """]').addEventListener('" & EventType & "', function(event){", _
	" " & IIf(StopPropagation, "event.stopPropagation();", ""), _
	" " & IIf(PreventDefault, "event.preventDefault();", ""), _
	" this.lastEvent = event;", _
	" document.title = " & VbaId & ";", _
	"}, " & IIf(UseCapture, "true", "false") & ");" _
	), vbLf)
	End If
	ElmScript.Text = ScriptText
	Call .body.appendChild(ElmScript)
	End With
	Set AddEventHandler = Me
	End Function

	' JavaScript での document.title の上書きに伴い呼び出される
	Private Sub TargetBrowser_TitleChange(ByVal Text As String)
	Dim VbaId: VbaId = Text
	If Not EventCollectionDict.Exists(VbaId) Then Exit Sub

	Dim TargetElement

	' On Error Resume Next
	' Set TargetElement = TargetBrowser.Document.querySelector("[" & DataVbaIdName & "=""" & VbaId & """]")
	' ' [TODO] documentMode が 8 以下だと、WebBrowser コントロールの Document.querySelector が動作しない模様
	' If Err.Number <> 0 Then Exit Sub

	If Not EventCollectionDict.Exists(VbaId) Then Exit Sub

	Dim EventInfo
	For Each EventInfo In EventCollectionDict(VbaId)
	Set TargetElement = EventInfo("DomElement")
	Call Callback(TargetElement, EventInfo)
	Next
	End Sub

	Private Sub Callback(DomElement, EventInfo)
	Dim DomEvent: Set DomEvent = DomElement.lastEvent
	Dim EventType: EventType = EventInfo("EventType")

	If TargetBrowser.Document.documentMode < 9 Then
	' [TODO] DomEvent.Type は IE8 以下だとセットされない模様→ JavaScript 側にて独自に DomEvent.eventType を設定するようにしてある
	If DomEvent.EventType <> EventType Then Exit Sub
	Else
	If DomEvent.Type <> EventType Then Exit Sub
	End If

	Dim CallbackFunc: CallbackFunc = EventInfo("CallbackFunc")
	Dim CallObject: Set CallObject = EventInfo("CallObject")

	If CallObject Is Nothing Then
	Call Application.Run(CallbackFunc, EventType, DomElement, DomEvent)
	Else
	Call CallByName(CallObject, CallbackFunc, VbMethod, EventType, DomElement, DomEvent)
	End If
	End Sub
	Option Explicit

	Const WebBrowserNavigateError = 5001
	Const WebBrowserTimeout = 5002

	Private IsDocumentReady As Boolean
	Private DomEventUtil As ClsDomEventUtil
	Private CurrentTargetCell As Range
	Private CurrentFirstWeekday As Integer

	Private Sub CommandButton1_Click()
	Unload Me
	End Sub

	Private Sub UserForm_Initialize()
	CurrentFirstWeekday = 1
	CommandButton1.Cancel = False ' 準備(Activate)完了までは閉じる(Esc)機能を無効化
	End Sub

	Private Sub UserForm_Activate()
	Dim CellDateString
	On Error Resume Next
	If CurrentTargetCell.Value <> "" Then
	CellDateString = Format(CDate(CurrentTargetCell.Value), "yyyy/mm/dd")
	End If
	On Error GoTo 0
	FormPage = "https://nazo.furyutei.com/vbaparts/datepicker.html?initdate=" & CellDateString & "&firstday=" & CStr(FirstWeekday)
	Dim InputElement: Set InputElement = WebBrowser1.Document.getElementById("target-date")
	Set DomEventUtil = New ClsDomEventUtil
	Call DomEventUtil.Init(WebBrowser1).AddEventHandler(InputElement, "change", "EventCallback", Me)
	CommandButton1.Cancel = True
	End Sub

	Public Sub EventCallback(EventType, DomElement, DomEvent)
	' Debug.Print DomEvent.Type & ":" & DomElement.Value
	If Not (CurrentTargetCell Is Nothing) Then CurrentTargetCell.Value = CDate(DomElement.Value)
	End Sub

	Public Property Get Sunday() As Integer: Sunday = 0: End Property
	Public Property Get Monday() As Integer: Monday = 1: End Property
	Public Property Get Tuesday() As Integer: Tuesday = 2: End Property
	Public Property Get Wednesday() As Integer: Wednesday = 3: End Property
	Public Property Get Thursday() As Integer: Thursday = 4: End Property
	Public Property Get Friday() As Integer: Friday = 5: End Property
	Public Property Get Saturday() As Integer: Saturday = 6: End Property

	Public Property Set TargetCell(SpecifiedCell As Range)
	Set CurrentTargetCell = SpecifiedCell
	End Property

	Public Property Get TargetCell() As Range
	Set TargetCell = CurrentTargetCell
	End Property

	Public Property Let FirstWeekday(DayNumber As Integer)
	If DayNumber < 0 Or 6 < DayNumber Then
	DayNumber = 1
	End If
	CurrentFirstWeekday = DayNumber
	End Property

	Public Property Get FirstWeekday() As Integer
	FirstWeekday = CurrentFirstWeekday
	End Property

	Private Property Let FormPage(URL)
	Dim TimeoutTime: TimeoutTime = Now() + TimeValue("00:00:30")
	IsDocumentReady = False
	With WebBrowser1
	Call .Navigate(URL)
	Do While Not IsDocumentReady
	If TimeoutTime <= Now() Then Call Err.Raise(WebBrowserTimeout, Description:="タイムアウトしました")
	DoEvents
	Loop
	End With
	End Property

	Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
	IsDocumentReady = True
	End Sub

	Private Sub WebBrowser1_NavigateError(ByVal pDisp As Object, URL As Variant, frame As Variant, StatusCode As Variant, Cancel As Boolean)
	Call Err.Raise(WebBrowserNavigateError, Description:="ページ読み込み失敗" & vbLf & vbLf & URL & vbLf & vbLf & "実行時エラー: " & StatusCode & " (" & Hex(StatusCode) & ")")
	End Sub
	Option Explicit

	Sub DatePicker()
	Dim TargetCell As Range: Set TargetCell = ActiveCell
	Dim TargetWindow As Window: Set TargetWindow = ActiveWindow
	Dim TargetDisplayPosition As ScreenPosition: TargetDisplayPosition = ConvertToScreenPosition(TargetCell.Top, TargetCell.Left)
	Dim TargetDisplayDotsPerPoint As DotsPerPoint: TargetDisplayDotsPerPoint = GetDisplayDotsPerPoint()
	Dim WindowScale As Double: WindowScale = TargetWindow.Zoom / 100#
	Dim FormTopOffset As Double: FormTopOffset = 0 * WindowScale
	Dim FormLeftOffset As Double: FormLeftOffset = TargetCell.MergeArea.Width * WindowScale
	Dim FormTop As Double: FormTop = (TargetDisplayPosition.y / TargetDisplayDotsPerPoint.y) + FormTopOffset
	Dim FormLeft As Double: FormLeft = (TargetDisplayPosition.x / TargetDisplayDotsPerPoint.x) + FormLeftOffset
	Dim TargetDatePicker As FormDatePicker: Set TargetDatePicker = FormDatePicker
	Call SetUserFormPosition(TargetDatePicker, FormTop, FormLeft)
	With TargetDatePicker
	Set .TargetCell = TargetCell ' 日付取得対象のセル指定
	.FirstWeekday = .Monday ' カレンダー左端の曜日指定
	Call .Show(vbModal)
	End With
	End Sub
	Option Explicit

	Public Sub Rbn_customUI_onLoad(ribbon As IRibbonUI)
	' Code for onLoad callback. Ribbon control customUI

	End Sub

	Public Sub Rbn_DatePicker_Calendar_OpenDatePicker_onAction(control As IRibbonControl)
	' Code for onAction callback. Ribbon control button
	Call DatePicker
	End Sub
	Option Explicit

	'【TODO】
	' - ActiveWindowが解像度が違うモニタ(デスクトップ)間にまたがっている場合にはUserFormの表示や位置が崩れてしまう(画面端にスナップした場合等にも発生)

	' 【覚書】
	' - 環境によってはActiveCellがActiveWindowの右の方にあるとUserFormの表示位置が左によってきてしまう場合がある（PointsToScreenPixelsXが正しい値を返さない模様）
	' → Microsoft 365のエクセルにて「ファイル＞オプション＞設定＞全般＞ユーザーインターフェイスのオプション＞複数ディスプレイを使用する場合」で
	' ○ 表示を優先した最適化 (アプリケーションの再起動が必要)
	' 　を選択していると、マルチディスプレイ環境にて発生する場合があることが判明（https://twitter.com/furyutei/status/1645413942582448129）
	' この場合には
	' ○ 互換性に対応した最適化
	' に変更後、再起動すれば、改善される模様

	Private Type RECT
	Left As Long
	Top As Long
	Right As Long
	Bottom As Long
	End Type

	Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
	Private Declare PtrSafe Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" (ByVal pacc As Object, phwnd As LongPtr) As LongPtr

	Type ScreenPosition
	x As Double
	y As Double
	End Type

	Type DotsPerPoint
	x As Double
	y As Double
	End Type

	Type CoordinateFactor
	x As Double
	y As Double
	End Type

	Function ConvertToScreenPosition(TargetTop, TargetLeft, Optional TargetWindow As Window) As ScreenPosition
	If TargetWindow Is Nothing Then Set TargetWindow = ActiveWindow
	Dim Result As ScreenPosition
	Dim PaneIndex As Long, WorkPane As Pane, WorkRange As Range
	For PaneIndex = 1 To TargetWindow.Panes.Count
	Set WorkPane = TargetWindow.Panes(PaneIndex)
	With WorkPane.VisibleRange
	If _
	((.Top <= TargetTop) And (TargetTop < .Top + .Height)) And _
	((.Left <= TargetLeft) And (TargetLeft < .Left + .Width)) _
	Then
	Result.x = WorkPane.PointsToScreenPixelsX(TargetLeft)
	Result.y = WorkPane.PointsToScreenPixelsY(TargetTop)
	Exit For
	End If
	End With
	Next
	ConvertToScreenPosition = Result
	End Function

	Function GetDisplayDotsPerPoint(Optional TargetWindow As Window) As DotsPerPoint
	If TargetWindow Is Nothing Then Set TargetWindow = ActiveWindow
	Dim Result As DotsPerPoint
	Dim WindowRect As RECT
	If Application.Version < 15# Then
	' Excel 2010以前のバージョンだとWindowオブジェクトにはhWndプロパティがない（SDIのためと思われる）
	' →代わりにApplication.hWndを使用
	Call GetWindowRect(Application.hWnd, WindowRect)
	Else
	Call GetWindowRect(TargetWindow.hWnd, WindowRect)
	End If
	With WindowRect
	Result.x = (.Bottom - .Top) / TargetWindow.Height
	Result.y = (.Right - .Left) / TargetWindow.Width
	End With
	GetDisplayDotsPerPoint = Result
	End Function

	Function SetUserFormPosition(TargetForm, Top As Double, Left As Double, Optional Calibration As Boolean = True) As CoordinateFactor
	'【覚書】
	' UserFormの表示位置(.Top/.Left)は画面左上を基点として(ポイント数で)指定するはずだが、何故か想定する位置より右下にずれてしまうことがある
	' その場合は経験上、表示したい位置(ポイント)の値にある係数（高さと幅(.Height/.Width)の設定値と実測値の比率・例:14/15=0.9333…）を掛けるとちょうどよい位置となる模様
	Dim Result As CoordinateFactor
	With TargetForm
	.StartUpPosition = 0 ' 0:Manual, 1:CenterOwner, 2:CenterScreen, 3:WindowsDefault
	.Top = Top
	.Left = Left
	If Not Calibration Then
	Result.y = 1#: Result.x = 1#
	GoTo CLEANUP
	End If
	Dim Height As Double: Height = .Height
	Dim Width As Double: Width = .Width
	Dim FormhWnd As LongPtr: Call WindowFromObject(TargetForm, FormhWnd)
	Dim FormRect As RECT: Call GetWindowRect(FormhWnd, FormRect)
	Dim TargetDisplayDotsPerPoint As DotsPerPoint: TargetDisplayDotsPerPoint = GetDisplayDotsPerPoint()
	Dim ActualHeight As Double: ActualHeight = (FormRect.Bottom - FormRect.Top) / TargetDisplayDotsPerPoint.y
	Dim ActualWidth As Double: ActualWidth = (FormRect.Right - FormRect.Left) / TargetDisplayDotsPerPoint.x
	Dim FormCoordinateFactorY As Double: FormCoordinateFactorY = Height / ActualHeight
	Dim FormCoordinateFactorX As Double: FormCoordinateFactorX = Width / ActualWidth
	.Top = Top * FormCoordinateFactorY
	.Left = Left * FormCoordinateFactorX
	Result.y = FormCoordinateFactorY
	Result.x = FormCoordinateFactorX
	End With

	CLEANUP:
	SetUserFormPosition = Result
	End Function