Results of 1 - 1 of about 37699 for IF (0.008 sec.)
- [[20230331101731]]
- #score: 1591
- @digest: 0feca310b6b00094188a8c53f1a5888f
- @id: 93888
- @mdate: 2023-04-05T01:45:10Z
- @size: 42061
- @type: text/plain
- #keywords: seldate (179863), btnset (157142), commandbutton (86284), lmtleft (73130), textboxy (68594), inidate (63491), executing (61313), lmttop (56000), spiny (54875), withevents (54468), msforms (51839), buttonnextm (50119), buttonprevm (50119), buttontoday (50119), fmspecialeffectbump (49391), myleft (49147), limittoedge (46907), fmtextaligncenter (46207), fheight (45473), mytop (45102), callercell (44285), newdate (43487), forms (41909), arect (40590), controls (38292), crect (35753), fwidth (35180), px2ptx (33766), apicursorpos (32493), textalign (32082), specialeffect (25213), height (22719)
- 『ポップアップでカレンダーを出す方法』（波冠）
初めまして。 当方ドが付くエクセル初心者です。 皆様に教えていただきたいのですが、セルクリックでカレンダーがポップアップで表示されて日付が入力されたら閉じるような事は出来るのでしょうか? また、出来ない場合↑に近いやり方は何かありますか? よろしくお願いします。 ＜ 使用 Excel:Excel2019、使用 OS:Windows11 ＞ ---- ＞『ポップアップでカレンダーを出す方法』 そのカレンダーは自作ですか。それとも他のソフトですか。 （?） 2023/03/31(金) 10:43:23 ---- [[20210615194052]] 『DatePicker』（´・ω・`） 先賢の遺産 （火災報知器） 2023/03/31(金) 10:46:35 ---- 任意のセルを選択後、データー、入力規則、リスト。リストに 任意の日付[範囲でもOK]を指定とかでは。ダメなのでしょうね。^^; m(__)m （隠居Z） 2023/03/31(金) 10:48:11 ---- 可能ですよ。 1. セルクリック （ VBAのイベントを使用して ） 2. ポップアップ（ カレンダーがポップアップを表示して ） 3.日付をセルに入力させる（ 日付は、いつのですか? ） 4.閉じるとは?（ ポップアップを閉じる? ） ※場合によってはカレンダーはいらないかもです いずれにしても…VBAかな 以前に、ここの回答者の（もこな2）さんに教えていただいた 下記URLのカレンダーも良いと思いました。 https://blog.djuggernaut.com/excel-vba-calendar-control/ （あみな） 2023/03/31(金) 11:00:55 ---- [[20150602101200]] 『ユーザーフォームにカレンダー』（yuki） こういうのもあるよ!! でも（´・ω・`）さんのほうが使いやすい。 （稲葉） 2023/03/31(金) 11:16:42 ---- バグ直してないかもしれないです... （´・ω・`） 2023/03/31(金) 11:54:07 ---- 皆さまありがとうございます! 試してみます! また何か解らなかったら質問させてください(^^) （波冠） 2023/03/31(金) 14:56:09 ---- 手持ちの実験道具(ユーザーフォーム)をちょっと強引に弄って遊んでいたら終わってしまった様です。 仰るところの「ポップアップ」のイメージにかなうかどうかアレですが、 その辺を中心に試してみましたので、まぁ一応置かせて下さい。 (別に終わるのを見計らっていた訳ではないですからね ^^;) ■[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 = "MS ゴシック" .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 ---- 白茶さん お返事遅くなり申し訳ありませんm・・m ありがとうございます! ただ、当方まったくの初心者でどこに入れ込めばいいのか解らないのですがVBAで対象シートのコードにいれればいいんですか? （波冠） 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/04(火) 20:42:21 ---- あみなさん、フォローありがとうございます。 いやー、確かにちょっと気付くの遅かったんですけど あれだけ色んな方々から具体的な案内を受けて、 > 皆さまありがとうございます! > 試してみます! とも仰ってたし、 さすがに初手の打ち方ぐらいはすぐに自力で辿り着けただろうしなぁ 今さらだよなぁ... と、レス返すの躊躇ってしまいました。^^; （白茶） 2023/04/05(水) 08:59:04 ---- ご返信ありがとうございます! 白茶さんのおっしゃる通り他の方々のお答えでカレンダーはできました。 ですが、初心者ですので色々なものを試してみたくて追加質問してしまいました。申し訳ありません。 あみなさん、えらーさんもありがとうございます! （波冠） 2023/04/05(水) 10:24:29 ---- ＞セルクリックでカレンダーがポップアップで表示されて日付が入力されたら閉じるような事は出来るのでしょうか? ＞カレンダーはできました。 で解決したんですか。 （はな） 2023/04/05(水) 10:45:10... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202303/20230331101731.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97063 documents and 608337 words.
訪問者：