[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ポップアップでカレンダーを出す方法』（波冠）
初めまして。
当方ドが付くエクセル初心者です。
皆様に教えていただきたいのですが、セルクリックでカレンダーがポップアップで表示されて日付が入力されたら閉じるような事は出来るのでしょうか？
また、出来ない場合↑に近いやり方は何かありますか？
よろしくお願いします。
＜ 使用 Excel：Excel2019、使用 OS：Windows11 ＞
先賢の遺産
（火災報知器） 2023/03/31(金) 10:46:35
可能ですよ。
1. セルクリック （ VBAのイベントを使用して ） 2. ポップアップ（ カレンダーがポップアップを表示して ） 3.日付をセルに入力させる（ 日付は、いつのですか？ ） 4.閉じるとは？（ ポップアップを閉じる？ ）
※場合によってはカレンダーはいらないかもです いずれにしても…VBAかな
以前に、ここの回答者の（もこな２）さんに教えていただいた 下記URLのカレンダーも良いと思いました。
https://blog.djuggernaut.com/excel-vba-calendar-control/
（あみな） 2023/03/31(金) 11:00:55
こういうのもあるよ！！
でも（´・ω・`）さんのほうが使いやすい。 （稲葉） 2023/03/31(金) 11:16:42
バグ直してないかもしれないです... （´・ω・`） 2023/03/31(金) 11:54:07
手持ちの実験道具(ユーザーフォーム)をちょっと強引に弄って遊んでいたら終わってしまった様です。 仰るところの「ポップアップ」のイメージにかなうかどうかアレですが、 その辺を中心に試してみましたので、まぁ一応置かせて下さい。
(別に終わるのを見計らっていた訳ではないですからね ^^;)
■[UserForm1]モジュール
Option Explicit
Rem API関連宣言---------------------------------------------------------------------------------------------------------
Private Type apiCursorPos
x As Long
y As Long
End Type
Private Type apiRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Const GWL_STYLE = (-16&)
Private Const GWL_EXSTYLE = (-20&)
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_CAPTION = &HC00000
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As apiCursorPos) As Long
Private Const SPI_GETWORKAREA = 48
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function GetCaretPos Lib "user32.dll" (ByRef lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As apiCursorPos) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Rem 色定数--------------------------------------------------------------------------------------------------------------
Private Const C_GRAY As Long = &H7F7F7F
Private Const C_BLACK As Long = &H0
Private Const C_GREEN As Long = &HFF00&
Private Const C_YELLOW As Long = &HFFFF&
Private Const C_DEF As Long = &HC0FFFF
Private Const C_DEFSUN As Long = &HC0C0FF
Private Const C_DEFSAT As Long = &HFFC0C0
Private Const C_FONTSUN As Long = &HFF&
Private Const C_FONTSAT As Long = &HFF0000
Rem 内部処理用変数------------------------------------------------------------------------------------------------------
Private SelDate As Date, dMax As Date, dMin As Date
Private Executing As Long, CallerCell As Range
Private WithEvents ap As Application, addr As String
Rem コントロール変数----------------------------------------------------------------------------------------------------
Private Label1 As MSForms.Label
Private Label2 As MSForms.Label
Private Label3 As MSForms.Label
Private Label4 As MSForms.Label
Private Label5 As MSForms.Label
Private Label6 As MSForms.Label
Private Label7 As MSForms.Label
Private LabelPrev As MSForms.Label
Private LabelNext As MSForms.Label
Private WithEvents TextBoxY As MSForms.TextBox
Private WithEvents SpinY As MSForms.SpinButton
Private WithEvents ComboM As MSForms.ComboBox
Private Label_SelDate As MSForms.Label
Private WithEvents Btn11 As MSForms.CommandButton
Private WithEvents Btn12 As MSForms.CommandButton
Private WithEvents Btn13 As MSForms.CommandButton
Private WithEvents Btn14 As MSForms.CommandButton
Private WithEvents Btn15 As MSForms.CommandButton
Private WithEvents Btn16 As MSForms.CommandButton
Private WithEvents Btn17 As MSForms.CommandButton
Private WithEvents Btn21 As MSForms.CommandButton
Private WithEvents Btn22 As MSForms.CommandButton
Private WithEvents Btn23 As MSForms.CommandButton
Private WithEvents Btn24 As MSForms.CommandButton
Private WithEvents Btn25 As MSForms.CommandButton
Private WithEvents Btn26 As MSForms.CommandButton
Private WithEvents Btn27 As MSForms.CommandButton
Private WithEvents Btn31 As MSForms.CommandButton
Private WithEvents Btn32 As MSForms.CommandButton
Private WithEvents Btn33 As MSForms.CommandButton
Private WithEvents Btn34 As MSForms.CommandButton
Private WithEvents Btn35 As MSForms.CommandButton
Private WithEvents Btn36 As MSForms.CommandButton
Private WithEvents Btn37 As MSForms.CommandButton
Private WithEvents Btn41 As MSForms.CommandButton
Private WithEvents Btn42 As MSForms.CommandButton
Private WithEvents Btn43 As MSForms.CommandButton
Private WithEvents Btn44 As MSForms.CommandButton
Private WithEvents Btn45 As MSForms.CommandButton
Private WithEvents Btn46 As MSForms.CommandButton
Private WithEvents Btn47 As MSForms.CommandButton
Private WithEvents Btn51 As MSForms.CommandButton
Private WithEvents Btn52 As MSForms.CommandButton
Private WithEvents Btn53 As MSForms.CommandButton
Private WithEvents Btn54 As MSForms.CommandButton
Private WithEvents Btn55 As MSForms.CommandButton
Private WithEvents Btn56 As MSForms.CommandButton
Private WithEvents Btn57 As MSForms.CommandButton
Private WithEvents Btn61 As MSForms.CommandButton
Private WithEvents Btn62 As MSForms.CommandButton
Private WithEvents Btn63 As MSForms.CommandButton
Private WithEvents Btn64 As MSForms.CommandButton
Private WithEvents Btn65 As MSForms.CommandButton
Private WithEvents Btn66 As MSForms.CommandButton
Private WithEvents Btn67 As MSForms.CommandButton
Private WithEvents ButtonToday As MSForms.CommandButton
Private WithEvents ButtonPrevM As MSForms.CommandButton
Private WithEvents ButtonNextM As MSForms.CommandButton
Private WithEvents ButtonEsc As MSForms.CommandButton
Rem コントロール群の配置------------------------------------------------------------------------------------------------
Private Sub PrepareControls()
Me.Font.Name = "MS UI Gothic"
Me.Font.Size = 9
Set Label1 = Me.Controls.Add("Forms.Label.1", "Label1")
With Label1
.Top = 17: .Height = 12: .Left = 0: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Sun"
.ForeColor = C_FONTSUN
.BackColor = C_DEFSUN
End With
Set Label2 = Me.Controls.Add("Forms.Label.1", "Label2")
With Label2
.Top = 17: .Height = 12: .Left = 21: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Mon"
.BackColor = C_DEF
End With
Set Label3 = Me.Controls.Add("Forms.Label.1", "Label3")
With Label3
.Top = 17: .Height = 12: .Left = 42: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Tue"
.BackColor = C_DEF
End With
Set Label4 = Me.Controls.Add("Forms.Label.1", "Label4")
With Label4
.Top = 17: .Height = 12: .Left = 63: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Wed"
.BackColor = C_DEF
End With
Set Label5 = Me.Controls.Add("Forms.Label.1", "Label5")
With Label5
.Top = 17: .Height = 12: .Left = 84: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Thu"
.BackColor = C_DEF
End With
Set Label6 = Me.Controls.Add("Forms.Label.1", "Label6")
With Label6
.Top = 17: .Height = 12: .Left = 105: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Fri"
.BackColor = C_DEF
End With
Set Label7 = Me.Controls.Add("Forms.Label.1", "Label7")
With Label7
.Top = 17: .Height = 12: .Left = 126: .Width = 21
.SpecialEffect = fmSpecialEffectBump
.TextAlign = fmTextAlignCenter
.Caption = "Sat"
.ForeColor = C_FONTSAT
.BackColor = C_DEFSAT
End With
Set TextBoxY = Me.Controls.Add("Forms.TextBox.1", "TextBoxY")
With TextBoxY
.Top = 1: .Height = 15: .Left = 30: .Width = 28
.MaxLength = 4
.SelectionMargin = False
.TextAlign = fmTextAlignCenter
.IMEMode = fmIMEModeDisable
.Locked = True
End With
Set SpinY = Me.Controls.Add("Forms.SpinButton.1", "SpinY")
With SpinY
.Top = 0: .Height = 16: .Left = 58: .Width = 15
End With
Set ComboM = Me.Controls.Add("Forms.ComboBox.1", "ComboM")
With ComboM
.Top = 1: .Height = 15: .Left = 76: .Width = 45
.SelectionMargin = False
.Style = fmStyleDropDownList
.Font.Name = "ＭＳ ゴシック"
.AddItem " 1 jan"
.AddItem " 2 feb"
.AddItem " 3 mar"
.AddItem " 4 apr"
.AddItem " 5 may"
.AddItem " 6 jun"
.AddItem " 7 jul"
.AddItem " 8 aug"
.AddItem " 9 sep"
.AddItem "10 oct"
.AddItem "11 nov"
.AddItem "12 dec"
.ListWidth = .Width
.ColumnWidths = .Width
.ListRows = 12
End With
Set Label_SelDate = Me.Controls.Add("Forms.Label.1", "Label_SelDate")
With Label_SelDate
.Top = 145: .Height = 15 + 1.5: .Left = 42: .Width = 105
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignCenter
.Font.Size = 12
End With
Me.Font.Size = 10
Set Btn11 = Me.Controls.Add("Forms.CommandButton.1", "Btn11")
With Btn11
.Top = 29: .Height = 19: .Left = 0: .Width = 21
End With
Set Btn12 = Me.Controls.Add("Forms.CommandButton.1", "Btn12")
With Btn12
.Top = 29: .Height = 19: .Left = 21: .Width = 21
End With
Set Btn13 = Me.Controls.Add("Forms.CommandButton.1", "Btn13")
With Btn13
.Top = 29: .Height = 19: .Left = 42: .Width = 21
End With
Set Btn14 = Me.Controls.Add("Forms.CommandButton.1", "Btn14")
With Btn14
.Top = 29: .Height = 19: .Left = 63: .Width = 21
End With
Set Btn15 = Me.Controls.Add("Forms.CommandButton.1", "Btn15")
With Btn15
.Top = 29: .Height = 19: .Left = 84: .Width = 21
End With
Set Btn16 = Me.Controls.Add("Forms.CommandButton.1", "Btn16")
With Btn16
.Top = 29: .Height = 19: .Left = 105: .Width = 21
End With
Set Btn17 = Me.Controls.Add("Forms.CommandButton.1", "Btn17")
With Btn17
.Top = 29: .Height = 19: .Left = 126: .Width = 21
End With
Set Btn21 = Me.Controls.Add("Forms.CommandButton.1", "Btn21")
With Btn21
.Top = 48: .Height = 19: .Left = 0: .Width = 21
End With
Set Btn22 = Me.Controls.Add("Forms.CommandButton.1", "Btn22")
With Btn22
.Top = 48: .Height = 19: .Left = 21: .Width = 21
End With
Set Btn23 = Me.Controls.Add("Forms.CommandButton.1", "Btn23")
With Btn23
.Top = 48: .Height = 19: .Left = 42: .Width = 21
End With
Set Btn24 = Me.Controls.Add("Forms.CommandButton.1", "Btn24")
With Btn24
.Top = 48: .Height = 19: .Left = 63: .Width = 21
End With
Set Btn25 = Me.Controls.Add("Forms.CommandButton.1", "Btn25")
With Btn25
.Top = 48: .Height = 19: .Left = 84: .Width = 21
End With
Set Btn26 = Me.Controls.Add("Forms.CommandButton.1", "Btn26")
With Btn26
.Top = 48: .Height = 19: .Left = 105: .Width = 21
End With
Set Btn27 = Me.Controls.Add("Forms.CommandButton.1", "Btn27")
With Btn27
.Top = 48: .Height = 19: .Left = 126: .Width = 21
End With
Set Btn31 = Me.Controls.Add("Forms.CommandButton.1", "Btn31")
With Btn31
.Top = 67: .Height = 19: .Left = 0: .Width = 21
End With
Set Btn32 = Me.Controls.Add("Forms.CommandButton.1", "Btn32")
With Btn32
.Top = 67: .Height = 19: .Left = 21: .Width = 21
End With
Set Btn33 = Me.Controls.Add("Forms.CommandButton.1", "Btn33")
With Btn33
.Top = 67: .Height = 19: .Left = 42: .Width = 21
End With
Set Btn34 = Me.Controls.Add("Forms.CommandButton.1", "Btn34")
With Btn34
.Top = 67: .Height = 19: .Left = 63: .Width = 21
End With
Set Btn35 = Me.Controls.Add("Forms.CommandButton.1", "Btn35")
With Btn35
.Top = 67: .Height = 19: .Left = 84: .Width = 21
End With
Set Btn36 = Me.Controls.Add("Forms.CommandButton.1", "Btn36")
With Btn36
.Top = 67: .Height = 19: .Left = 105: .Width = 21
End With
Set Btn37 = Me.Controls.Add("Forms.CommandButton.1", "Btn37")
With Btn37
.Top = 67: .Height = 19: .Left = 126: .Width = 21
End With
Set Btn41 = Me.Controls.Add("Forms.CommandButton.1", "Btn41")
With Btn41
.Top = 86: .Height = 19: .Left = 0: .Width = 21
End With
Set Btn42 = Me.Controls.Add("Forms.CommandButton.1", "Btn42")
With Btn42
.Top = 86: .Height = 19: .Left = 21: .Width = 21
End With
Set Btn43 = Me.Controls.Add("Forms.CommandButton.1", "Btn43")
With Btn43
.Top = 86: .Height = 19: .Left = 42: .Width = 21
End With
Set Btn44 = Me.Controls.Add("Forms.CommandButton.1", "Btn44")
With Btn44
.Top = 86: .Height = 19: .Left = 63: .Width = 21
End With
Set Btn45 = Me.Controls.Add("Forms.CommandButton.1", "Btn45")
With Btn45
.Top = 86: .Height = 19: .Left = 84: .Width = 21
End With
Set Btn46 = Me.Controls.Add("Forms.CommandButton.1", "Btn46")
With Btn46
.Top = 86: .Height = 19: .Left = 105: .Width = 21
End With
Set Btn47 = Me.Controls.Add("Forms.CommandButton.1", "Btn47")
With Btn47
.Top = 86: .Height = 19: .Left = 126: .Width = 21
End With
Set Btn51 = Me.Controls.Add("Forms.CommandButton.1", "Btn51")
With Btn51
.Top = 105: .Height = 19: .Left = 0: .Width = 21
End With
Set Btn52 = Me.Controls.Add("Forms.CommandButton.1", "Btn52")
With Btn52
.Top = 105: .Height = 19: .Left = 21: .Width = 21
End With
Set Btn53 = Me.Controls.Add("Forms.CommandButton.1", "Btn53")
With Btn53
.Top = 105: .Height = 19: .Left = 42: .Width = 21
End With
Set Btn54 = Me.Controls.Add("Forms.CommandButton.1", "Btn54")
With Btn54
.Top = 105: .Height = 19: .Left = 63: .Width = 21
End With
Set Btn55 = Me.Controls.Add("Forms.CommandButton.1", "Btn55")
With Btn55
.Top = 105: .Height = 19: .Left = 84: .Width = 21
End With
Set Btn56 = Me.Controls.Add("Forms.CommandButton.1", "Btn56")
With Btn56
.Top = 105: .Height = 19: .Left = 105: .Width = 21
End With
Set Btn57 = Me.Controls.Add("Forms.CommandButton.1", "Btn57")
With Btn57
.Top = 105: .Height = 19: .Left = 126: .Width = 21
End With
Set Btn61 = Me.Controls.Add("Forms.CommandButton.1", "Btn61")
With Btn61
.Top = 124: .Height = 19: .Left = 0: .Width = 21
End With
Set Btn62 = Me.Controls.Add("Forms.CommandButton.1", "Btn62")
With Btn62
.Top = 124: .Height = 19: .Left = 21: .Width = 21
End With
Set Btn63 = Me.Controls.Add("Forms.CommandButton.1", "Btn63")
With Btn63
.Top = 124: .Height = 19: .Left = 42: .Width = 21
End With
Set Btn64 = Me.Controls.Add("Forms.CommandButton.1", "Btn64")
With Btn64
.Top = 124: .Height = 19: .Left = 63: .Width = 21
End With
Set Btn65 = Me.Controls.Add("Forms.CommandButton.1", "Btn65")
With Btn65
.Top = 124: .Height = 19: .Left = 84: .Width = 21
End With
Set Btn66 = Me.Controls.Add("Forms.CommandButton.1", "Btn66")
With Btn66
.Top = 124: .Height = 19: .Left = 105: .Width = 21
End With
Set Btn67 = Me.Controls.Add("Forms.CommandButton.1", "Btn67")
With Btn67
.Top = 124: .Height = 19: .Left = 126: .Width = 21
End With
Set ButtonToday = Me.Controls.Add("Forms.CommandButton.1", "ButtonToday")
With ButtonToday
.Top = 143: .Height = 18: .Left = 0: .Width = 36
.Caption = "Today"
.BackColor = C_YELLOW
.BackStyle = fmBackStyleTransparent
.Accelerator = "t"
End With
Me.Font.Size = 9
Set LabelPrev = Me.Controls.Add("Forms.Label.1", "LabelPrev")
With LabelPrev
.Top = 0: .Height = 16: .Left = 0: .Width = 24
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("MailMergeGoToPreviousRecord", 16, 16)
End With
Set ButtonPrevM = Me.Controls.Add("Forms.CommandButton.1", "ButtonPrevM")
With ButtonPrevM
.Top = 0: .Height = 16: .Left = 0: .Width = 24
.BackStyle = fmBackStyleTransparent
.Accelerator = ","
End With
Set LabelNext = Me.Controls.Add("Forms.Label.1", "LabelNext")
With LabelNext
.Top = 0: .Height = 16: .Left = 123: .Width = 24
.PicturePosition = fmPicturePositionCenter
.Picture = CommandBars.GetImageMso("MailMergeGoToNextRecord", 16, 16)
End With
Set ButtonNextM = Me.Controls.Add("Forms.CommandButton.1", "ButtonNextM")
With ButtonNextM
.Top = 0: .Height = 16: .Left = 123: .Width = 24
.BackStyle = fmBackStyleTransparent
.Accelerator = "."
End With
Set ButtonEsc = Me.Controls.Add("Forms.CommandButton.1", "ButtonEsc")
With ButtonEsc
.Top = -45: .Height = 21: .Left = -45: .Width = 27
.Cancel = True
.TabStop = False
End With
Me.Width = 152.25
Me.Height = 182.25
Me.Caption = "Date Picker"
End Sub
Rem 内部イベント--------------------------------------------------------------------------------------------------------
Private Sub UserForm_Initialize()
Call PrepareControls
Set ap = Excel.Application
addr = ActiveCell.Address(external:=True)
Me.StartupPosition = 0
SpinY.Max = 9999
SpinY.Min = 100
dMin = #1/1/100#
dMax = #12/31/9999#
Value = Date
End Sub
Private Sub ComboM_Change()
Value = DateSerial(Year(SelDate), ComboM.ListIndex + 1, Day(SelDate))
End Sub
Private Sub ButtonToday_Click()
Value = Date
If Executing Then
Executing = 2&
Me.Hide
End If
If Not CallerCell Is Nothing Then
CallerCell.Value = SelDate
Unload Me
End If
End Sub
Private Sub ButtonPrevM_Click()
Value = DateSerial(Year(SelDate), Month(SelDate) - 1, Day(SelDate))
End Sub
Private Sub ButtonNextM_Click()
Value = DateSerial(Year(SelDate), Month(SelDate) + 1, Day(SelDate))
End Sub
Private Sub ButtonEsc_Click()
If Executing Then Me.Hide Else Unload Me
End Sub
Private Sub SpinY_Change()
Value = DateSerial(SpinY.Value, Month(SelDate), Day(SelDate))
End Sub
Private Sub TextBoxY_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
With SpinY
Select Case KeyCode.Value
Case vbKeyUp
If .Value < .Max Then .Value = .Value + 1
KeyCode.Value = 0
Case vbKeyDown
If .Value > .Min Then .Value = .Value - 1
KeyCode.Value = 0
Case vbKeyLeft, vbKeyRight
KeyCode.Value = 0
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
End Select
End With
End Sub
Private Sub TextBoxY_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim st As Long, ln As Long, tx As String, tmp As String
Select Case KeyAscii.Value
Case Asc("0") To Asc("9")
tmp = TextBoxY.Text
tx = tmp
tmp = Right$(tx & Chr(KeyAscii), 4)
If Not IsDate(tmp & "/1/1") Then tmp = String$(3, "0") & Chr(KeyAscii)
If IsDate(tmp & "/1/1") Then SpinY.Value = Year(tmp & "/1/1")
End Select
End Sub
Private Sub TextBoxY_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
With TextBoxY
.SelStart = 0
.SelLength = 4
End With
End Sub
Private Sub Btn11_Click()
Call BtnSet(Btn11)
End Sub
Private Sub Btn12_Click()
Call BtnSet(Btn12)
End Sub
Private Sub Btn13_Click()
Call BtnSet(Btn13)
End Sub
Private Sub Btn14_Click()
Call BtnSet(Btn14)
End Sub
Private Sub Btn15_Click()
Call BtnSet(Btn15)
End Sub
Private Sub Btn16_Click()
Call BtnSet(Btn16)
End Sub
Private Sub Btn17_Click()
Call BtnSet(Btn17)
End Sub
Private Sub Btn21_Click()
Call BtnSet(Btn21)
End Sub
Private Sub Btn22_Click()
Call BtnSet(Btn22)
End Sub
Private Sub Btn23_Click()
Call BtnSet(Btn23)
End Sub
Private Sub Btn24_Click()
Call BtnSet(Btn24)
End Sub
Private Sub Btn25_Click()
Call BtnSet(Btn25)
End Sub
Private Sub Btn26_Click()
Call BtnSet(Btn26)
End Sub
Private Sub Btn27_Click()
Call BtnSet(Btn27)
End Sub
Private Sub Btn31_Click()
Call BtnSet(Btn31)
End Sub
Private Sub Btn32_Click()
Call BtnSet(Btn32)
End Sub
Private Sub Btn33_Click()
Call BtnSet(Btn33)
End Sub
Private Sub Btn34_Click()
Call BtnSet(Btn34)
End Sub
Private Sub Btn35_Click()
Call BtnSet(Btn35)
End Sub
Private Sub Btn36_Click()
Call BtnSet(Btn36)
End Sub
Private Sub Btn37_Click()
Call BtnSet(Btn37)
End Sub
Private Sub Btn41_Click()
Call BtnSet(Btn41)
End Sub
Private Sub Btn42_Click()
Call BtnSet(Btn42)
End Sub
Private Sub Btn43_Click()
Call BtnSet(Btn43)
End Sub
Private Sub Btn44_Click()
Call BtnSet(Btn44)
End Sub
Private Sub Btn45_Click()
Call BtnSet(Btn45)
End Sub
Private Sub Btn46_Click()
Call BtnSet(Btn46)
End Sub
Private Sub Btn47_Click()
Call BtnSet(Btn47)
End Sub
Private Sub Btn51_Click()
Call BtnSet(Btn51)
End Sub
Private Sub Btn52_Click()
Call BtnSet(Btn52)
End Sub
Private Sub Btn53_Click()
Call BtnSet(Btn53)
End Sub
Private Sub Btn54_Click()
Call BtnSet(Btn54)
End Sub
Private Sub Btn55_Click()
Call BtnSet(Btn55)
End Sub
Private Sub Btn56_Click()
Call BtnSet(Btn56)
End Sub
Private Sub Btn57_Click()
Call BtnSet(Btn57)
End Sub
Private Sub Btn61_Click()
Call BtnSet(Btn61)
End Sub
Private Sub Btn62_Click()
Call BtnSet(Btn62)
End Sub
Private Sub Btn63_Click()
Call BtnSet(Btn63)
End Sub
Private Sub Btn64_Click()
Call BtnSet(Btn64)
End Sub
Private Sub Btn65_Click()
Call BtnSet(Btn65)
End Sub
Private Sub Btn66_Click()
Call BtnSet(Btn66)
End Sub
Private Sub Btn67_Click()
Call BtnSet(Btn67)
End Sub
Private Sub ap_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If ActiveCell.Address(external:=True) <> addr Then Unload Me
End Sub
Private Sub ap_WindowDeactivate(ByVal Wb As Workbook, ByVal Wn As Window)
Unload Me
End Sub
Private Sub ap_SheetDeactivate(ByVal Sh As Object)
Unload Me
End Sub
Rem メインとなる機能----------------------------------------------------------------------------------------------------
Public Function Pickup(Optional InitialDate As Date) As Date
Executing = 1&
If Not InitialDate = Empty Then Value = InitialDate
Call SetMySizeAndPos(vbModal)
Me.Show vbModal
If Executing = 2& Then Pickup = SelDate
Executing = 0&
Unload Me
End Function
Public Sub PopupOnCell(Target As Range)
If Target Is Nothing Then Exit Sub
Set CallerCell = Target
Call SetMySizeAndPos(vbModeless)
Me.Show vbModeless
End Sub
Rem 内部処理サブルーチン------------------------------------------------------------------------------------------------
Private Sub SetMySizeAndPos(Mode As FormShowConstants)
Dim hw As LongPtr
Dim v As Single, h As Single
v = Me.InsideHeight
h = Me.InsideWidth
WindowFromAccessibleObject Me, hw
If Mode = vbModal Then
SetWindowLong hw, GWL_EXSTYLE, GetWindowLong(hw, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW
Else
SetWindowLong hw, GWL_EXSTYLE, GetWindowLong(hw, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
SetWindowLong hw, GWL_STYLE, GetWindowLong(hw, GWL_STYLE) And Not WS_CAPTION
End If
DrawMenuBar hw
v = Me.InsideHeight - v
Me.Height = Me.Height - v
h = Me.InsideWidth - h
Me.Width = Me.Width - h
If Mode = vbModal Then
Call GetTopLeftFromMouseCur(v, h, Me.Height, Me.Width)
Else
Call GetTopLeftFromCaretCellBR(v, h, Me.Height, Me.Width)
End If
Me.Top = v + (Me.Width - Me.InsideWidth)
Me.Left = h + (Me.Width - Me.InsideWidth)
End Sub
Public Property Get Value() As Date
Value = SelDate
End Property
Public Property Let Value(newDate As Date)
If SelDate = newDate Then Exit Property
SelDate = newDate
Call Set_Date
End Property
Public Property Get Max() As Date
Max = dMax
End Property
Public Property Let Max(newDate As Date)
If dMax = newDate Then Exit Property
dMax = newDate
Call Set_Date
If SelDate > dMax Then Value = dMax
End Property
Public Property Get Min() As Date
Min = dMin
End Property
Public Property Let Min(newDate As Date)
If dMin = newDate Then Exit Property
dMin = newDate
Call Set_Date
If SelDate < dMin Then Value = dMin
End Property
Private Sub Set_Date()
Dim c As MSForms.Control
Dim IniDate As Date, dis As Long, d As Date
ButtonPrevM.Enabled = True
LabelPrev.Visible = True
ButtonNextM.Enabled = True
LabelNext.Visible = True
ButtonToday.BackStyle = fmBackStyleTransparent
IniDate = DateSerial(Year(SelDate), Month(SelDate), 1)
If IniDate = #1/1/100# Then
dis = Weekday(IniDate) - 1
d = IniDate
ButtonPrevM.Enabled = False
LabelPrev.Visible = False
Else
If Weekday(IniDate) = 1 Then
d = IniDate - 7
Else
d = IniDate - Weekday(IniDate) + 1
End If
End If
If IniDate = #12/1/9999# Then
ButtonNextM.Enabled = False
LabelNext.Visible = False
End If
For Each c In Me.Controls
If TypeOf c Is MSForms.CommandButton And c.Name Like "Btn*" Then
If dis > 0 Then
c.Enabled = False
c.BackColor = C_GRAY
c.Tag = ""
c.Caption = ""
dis = dis - 1
Else
c.Enabled = True
c.Tag = d
c.Caption = Day(d)
c.ControlTipText = Format$(d, "yyyy/mm/dd (ddd)")
If Month(IniDate) = Month(d) Then
c.ForeColor = C_BLACK
c.Font.Bold = True
Else
c.ForeColor = C_GRAY
c.Font.Bold = False
End If
Select Case Weekday(d)
Case 1: c.BackColor = C_DEFSUN
Case 7: c.BackColor = C_DEFSAT
Case Else: c.BackColor = C_DEF
End Select
If d = Date Then
c.BackColor = C_YELLOW
c.ControlTipText = "Today: " & Format$(d, "yyyy/mm/dd (ddd)")
If d <> SelDate Then ButtonToday.BackStyle = fmBackStyleOpaque
End If
If d = SelDate Then c.BackColor = C_GREEN
If d < dMin Or d > dMax Then c.Enabled = False
If d = #12/31/9999# Then
dis = 42
Else
d = d + 1
End If
End If
End If
Next
Label_SelDate.Caption = Format$(SelDate, " yyyy/mm/dd (ddd)")
SpinY.Value = Year(SelDate)
With TextBoxY
.Text = Format$(SpinY.Value, "0000")
.SelStart = 0
.SelLength = 4
End With
ComboM.ListIndex = Month(SelDate) - 1
End Sub
Private Sub BtnSet(Target As MSForms.CommandButton)
Value = CDate(Target.Tag)
If Executing Then
Executing = 2&
Me.Hide
End If
If Not CallerCell Is Nothing Then
CallerCell.Value = SelDate
Unload Me
End If
End Sub
Rem ====================================================================================================================
Private Property Get xDPI() As Long
xDPI = GetDPI(LOGPIXELSX)
End Property
Private Property Get yDPI() As Long
yDPI = GetDPI(LOGPIXELSY)
End Property
Private Property Get xlPPI() As Long
xlPPI = Application.InchesToPoints(1)
End Property
Private Function GetDPI(nIndex As Long) As Long
Dim hDC As Long
hDC = GetDC(Application.hWnd)
GetDPI = GetDeviceCaps(hDC, nIndex)
ReleaseDC &H0, hDC
End Function
Private Function Px2PtX(aPixel As Long) As Single
Px2PtX = Int((aPixel * xlPPI / xDPI) / (xlPPI / xDPI)) * (xlPPI / xDPI)
End Function
Private Function Pt2PxX(aPoint As Single) As Long
Pt2PxX = Int(aPoint * xDPI / xlPPI)
End Function
Private Function Px2PtY(aPixel As Long) As Single
Px2PtY = Int((aPixel * xlPPI / yDPI) / (xlPPI / yDPI)) * (xlPPI / yDPI)
End Function
Private Function Pt2PxY(aPoint As Single) As Long
Pt2PxY = Int(aPoint * yDPI / xlPPI)
End Function
Rem ====================================================================================================================
Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える
Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示)
Rem False(規定値) ---- フォームの幅及び高さ分左上方向に減算する(フォームの表示方向が逆転する)
Private Sub GetTopLeftFromMouseCur(ByRef fTop As Single, ByRef fLeft As Single, _
ByVal fHeight As Single, ByVal fWidth As Single, _
Optional ByVal LimitToEdge As Boolean = False _
)
Dim cPos As apiCursorPos, MyTop As Single, MyLeft As Single
Dim aRect As apiRECT, LmtTop As Single, LmtLeft As Single
With aRect
.Bottom = GetSystemMetrics(SM_CYSCREEN)
.Right = GetSystemMetrics(SM_CXSCREEN)
End With
Call GetCursorPos(cPos)
MyTop = Px2PtY(cPos.y)
If MyTop < 0 Then MyTop = 0
LmtTop = Px2PtY(aRect.Bottom) - fHeight
If LmtTop < 0 Then LmtTop = 0
If MyTop > LmtTop Then
If MyTop > fHeight Then
MyTop = MyTop - fHeight
If LimitToEdge Then MyTop = LmtTop
Else
MyTop = LmtTop
End If
End If
MyLeft = Px2PtX(cPos.x)
If MyLeft < 0 Then MyLeft = 0
LmtLeft = Px2PtX(aRect.Right) - fWidth
If LmtLeft < 0 Then LmtLeft = 0
If MyLeft > LmtLeft Then
If MyLeft > fWidth Then
MyLeft = MyLeft - fWidth
If LimitToEdge Then MyLeft = LmtLeft
Else
MyLeft = LmtLeft
End If
End If
fTop = MyTop
fLeft = MyLeft
End Sub
Rem ====================================================================================================================
Rem 引数 LimitToEdge --- 画面の右または下にフォームがはみ出そうな場合の基点座標の補正方法を切り替える
Rem True ------------- はみ出る幅及び高さ分だけ左上方向に減算する(画面端にくっ付く感じでフォームを表示)
Rem False(規定値) ---- フォームの幅及び高さ分左上方向に減算する(フォームの表示方向が逆転する)
Private Sub GetTopLeftFromCaretCellBR(ByRef fTop As Single, ByRef fLeft As Single, _
ByVal fHeight As Single, ByVal fWidth As Single, _
Optional ByVal LimitToEdge As Boolean = False _
)
Dim MyTop As Single, MyLeft As Single
Dim aRect As apiRECT, LmtTop As Single, LmtLeft As Single
Dim cRect As apiRECT, cPos As apiCursorPos
Call SystemParametersInfo(SPI_GETWORKAREA, &H0, aRect, &H0)
Call GetCaretPos(cPos)
Call ClientToScreen(GetFocus(), cPos)
With cRect
.Top = cPos.y
.Left = cPos.x
.Bottom = .Top + Pt2PxY(ActiveCell.Height) * ActiveWindow.Zoom / 100
.Right = .Left + Pt2PxX(ActiveCell.Width) * ActiveWindow.Zoom / 100
End With
MyTop = Px2PtY(cRect.Bottom)
If MyTop < 0 Then MyTop = 0
If cRect.Bottom > aRect.Bottom Then MyTop = Px2PtY(cRect.Top)
If cRect.Top > aRect.Bottom Then MyTop = Px2PtY(aRect.Bottom)
LmtTop = Px2PtY(aRect.Bottom) - fHeight
If LmtTop < 0 Then LmtTop = 0
If MyTop > LmtTop Then
If MyTop > fHeight Then
MyTop = MyTop - fHeight
If LimitToEdge Then MyTop = LmtTop
Else
MyTop = LmtTop
End If
End If
MyLeft = Px2PtX(cRect.Right)
If MyLeft < 0 Then MyLeft = 0
If cRect.Right > aRect.Right Then MyLeft = Px2PtX(cRect.Left)
If cRect.Left > aRect.Right Then MyLeft = Px2PtX(aRect.Right)
LmtLeft = Px2PtX(aRect.Right) - fWidth
If LmtLeft < 0 Then LmtLeft = 0
If MyLeft > LmtLeft Then
If MyLeft > fWidth Then
MyLeft = MyLeft - fWidth
If LimitToEdge Then MyLeft = LmtLeft
Else
MyLeft = LmtLeft
End If
End If
fTop = MyTop
fLeft = MyLeft
End Sub
■シート上の右クリックイベントによる活用例
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = Me.Range("E5").Address Then
Cancel = True
UserForm1.PopupOnCell Target
ElseIf Target.Address = Me.Range("E8").Address Then
Cancel = True
Dim d As Date
d = UserForm1.Pickup(Target.Value)
If d Then Target.Value = d
End If
End Sub
（白茶） 2023/03/31(金) 15:49:48
（波冠） 2023/04/03(月) 10:35:37
（白茶）さんは、多分...その後このスレを見ていないですね。 夜の方が、どっちかと言うとよく見に来られるので詳しくは 聞いてください。
VBAにおいてプログラムを管理するモジュール（Module）の中で、 複数の種類があるんですが
コードの最後にある…↓この部分はシートモジュール入れるですよ。
■シート上の右クリックイベントによる活用例 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 〜 略 〜 End Sub
■[UserForm1]モジュール ※シートモジュール入れる以外の、上の全部はユーザーフォームモジュールですよ
下は参考になるURLです。
ExcelVBA入門第9回 5種類のモジュールの違い https://ateitexe.com/excel-vba-module/
VBEの使い方：VBE画面の全体説明 https://excel-ubara.com/excelvba1/EXCELVBA481.html
Excelユーザーフォーム入門 https://excel-ubara.com/excelvba3/
※上記URLにユーザーフォーム入門の目次に 詳しく書いてあるですよ。
（あみな） 2023/04/04(火) 18:47:07
あみなさん、フォローありがとうございます。
いやー、確かにちょっと気付くの遅かったんですけど あれだけ色んな方々から具体的な案内を受けて、
> 皆さまありがとうございます！
> 試してみます！
とも仰ってたし、
さすがに初手の打ち方ぐらいはすぐに自力で辿り着けただろうしなぁ 今さらだよなぁ... と、レス返すの躊躇ってしまいました。^^;
（白茶） 2023/04/05(水) 08:59:04
ですが、初心者ですので色々なものを試してみたくて追加質問してしまいました。申し訳ありません。
あみなさん、えらーさんもありがとうございます！
（波冠） 2023/04/05(水) 10:24:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.