如何添加日历、日期选择器？
How to add Calendar, Date-Picker?
我需要在 Excel 2013 年添加日历日期选择器。
我发现 MonthView 和 DT Picker 不再出现在 ActiveX 菜单中，并且据称包含这些内容的 CAB 文件的链接不起作用。有说明文档，但是依赖了一个不存在的控件
我有一个 Excel 插件可以满足我的需求，但我想用 VBA 来完成它，而不是在每台将使用它的机器上安装插件。
我已经使用 mscomct2.ocx 文件在 excel 中使用日期选择器。
您需要注册它，然后才能轻松使用日期选择器
一旦您注册了 mscomct2.ocx 控件（您将需要在所有将使用此手册的计算机上注册此文件！)，您可以在工作表或用户窗体中添加以下控件之一：
- 日期和时间选择器（DTPicker），left/top 的屏幕截图
- MonthView、right/bottom 的屏幕截图
工作表 (ActiveX)
- 在“开发工具”选项卡的“控件”组中，单击“插入”，然后单击右下角
更多控件按钮。
- 向下滚动并 select Microsoft 日期和时间选择器控件 6.0 (SP6) 或 Microsoft MonthView 控件 6.0 (SP6) 然后单击确定。
|
- 当你退出设计模式时，点击DTPicker控件是这样的，而MonthView需要更多space:
|
用户窗体
- 在 UserForm selected 的工具箱中，右键单击“控件”选项卡的空白 space，单击“附加控件”
- 向下滚动并勾选 Microsoft 日期和时间选择器控件 6.0 (SP6) 或 Microsoft MonthView 控件 6.0 (SP6):
|
- 现在控件位于您的控件选项卡中以添加到 UserForms
- 用户窗体上控件的默认大小：
无论哪种方式，您都需要在单击这些控件时执行操作。
有些用户如果 Excel 格式不正确，可能无法使用您的 DatePicker。我开发的代码将创建一个 dateGetter 用户窗体，获取用户的日期 selection 作为全局变量，然后删除该窗体。它应该与大多数系统兼容，尽管我没有在我自己的系统上测试过它。试一试。如果它对你有用，请大声说出来....
2020 年 8 月：
修复了一个小故障 - 当 select 以 return 形式打开的原始日期是“00:00:00 AM”时 - 我将其修复为 return 显示的日期在 label2 标题中。
此外 - MSForms 引用对于 dateGetter() 子例程的正常工作是必需的，否则在声明表单 objects 时您会收到错误消息。我添加了另一个子例程，可以通过 VBA 代码添加该引用，或者在 VBA 编辑器中转到“工具 --> 引用”和 select MSForms 引用。您必须在尝试 运行 dateGetter 宏之前执行此操作。
Public absDate As Date ' This Public Variable is necessary to pass selected date
Sub setGUIDReferences()
' NOTE: The dateGetter() sub will not work until the MSForms Reference is added to this workbook project
' You can add the MSForms reference by running this sub first
' Or go to Tools --> References and select the MSForms reference there
' included below are several other common references you can use for other projects just uncomment them to add
' *************************************************************************************************************
On Error Resume Next
'ThisWorkbook.VBProject.References.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 0, 0 ' Visual Basic For Applications
'ThisWorkbook.VBProject.References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 0, 0 ' Microsoft Excel 16.0 Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 0, 0 ' OLE Automation
'ThisWorkbook.VBProject.References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 0, 0 ' Microsoft Office 16.0 Object Library
ThisWorkbook.VBProject.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 0, 0 ' Microsoft Forms 2.0 Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 0, 0 ' Microsoft HTML Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 0, 0 ' Microsoft Internet Controls
'ThisWorkbook.VBProject.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 0, 0 ' Microsoft Scripting Runtime
'ThisWorkbook.VBProject.References.AddFromGuid "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}", 0, 0 ' Microsoft Windows Common Controls-2 6.0 (SP6)
'ThisWorkbook.VBProject.References.AddFromGuid "{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}", 0, 0 ' Microsoft Access 16.0 Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0 ' Microsoft Visual Basic for Applications Extensibility 5.3
'ThisWorkbook.VBProject.References.AddFromGuid "{F5078F18-C551-11D3-89B9-0000F81FE221}", 0, 0 ' Microsoft MSXML2 for XML Scraping
On Error GoTo 0
End Sub
Sub dateGetter()
' This creates dategetter userform for those without access to date picker
' Bug Fixed: Aug 2020, Selecting Original Date was resulting in 12:00:00 AM
'*********
' Note: MSForms Reference in Tools menu must be added to workbook first before this calendar script will work
' You can add several commonly used references by running the "setGUIDReferences()" subroutine above.
' Or go to Tools --> References and select the MSForms reference there
'*********
Dim myForm As Object, calendarForm As Object, newLabel As MSForms.Label, newSpinner As MSForms.SpinButton
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
Dim NewListBox As MSForms.ListBox
Dim smallDayArray
Dim xDiff As Long
Dim smallTextArray
Dim startDate As Date
Dim endDate As Date
Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)
'Create the User Form
With myForm
.Properties("Caption") = "Select Date Range"
.Properties("Width") = 247.5
.Properties("Height") = 350
End With
'create button
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "CommandButton1"
.Top = 288
.Left = 138
.Width = 42
.Height = 24
.Font.Size = 10
.Font.Name = "Tahoma"
.Caption = "Cancel"
End With
'create button
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "CommandButton2"
.Top = 288
.Left = 186
.Width = 42
.Height = 24
.Font.Size = 10
.Font.Name = "Tahoma"
.Caption = "Select"
End With
'create frame
Set NewFrame = myForm.designer.Controls.Add("Forms.frame.1")
With NewFrame
.Name = "Frame1"
.Top = 54
.Left = 24
.Width = 192
.Height = 180
.Font.Size = 9
.Font.Name = "Tahoma"
End With
'Create label1
Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
With newLabel
.Name = "Label1"
.Top = 30
.Left = 30
.Width = 102
.Height = 18
.Font.Size = 12
.Font.Name = "Tahoma"
.ForeColor = RGB(128, 0, 0)
.BackColor = RGB(256, 256, 256)
.Caption = "November 2017"
End With
'Create label2
Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
With newLabel
.Name = "Label2"
.Top = 258
.Left = 36
.Width = 174
.Height = 18
.Font.Size = 12
.Font.Name = "Tahoma"
.ForeColor = RGB(0, 0, 0)
.Caption = "01/01/2017"
End With
'Create SpinButton1
Set newSpinner = myForm.designer.Controls.Add("Forms.spinbutton.1")
With newSpinner
.Name = "SpinButton1"
.Top = 24
.Left = 144
.Width = 12.75
.Height = 25
End With
'Create Calendar Header Labels
smallDayArray = Array("S", "M", "T", "W", "T", "F", "S")
smallTextArray = Array("day1", "day2", "day3", "day4", "day5", "day6", "day7")
xDiff = 18
For i = LBound(smallDayArray) To UBound(smallDayArray)
Set lbl = NewFrame.Controls.Add("Forms.Label.1")
With lbl
.Name = smallTextArray(i)
.Top = 6
.Left = xDiff
.Width = 12
.Height = 18
.Font.Size = 11
.Font.Name = "Tahoma"
.Caption = smallDayArray(i)
End With
xDiff = xDiff + 24
Next i
'Create Calendar boxes labels
arrCounter = 1
For j = 1 To 6
xDiff = 12
For k = 1 To 7
Set lbl = NewFrame.Controls.Add("Forms.Label.1")
With lbl
.Name = "lb_" & arrCounter
Select Case j
Case 1
.Top = 24
Case 2
.Top = 48
Case 3
.Top = 72
Case 4
.Top = 96
Case 5
.Top = 120
Case 6
.Top = 144
End Select
.Left = xDiff
.Width = 18
.Height = 18
.Font.Size = 11
.Font.Name = "Tahoma"
.Caption = " " & arrCounter
.ForeColor = RGB(128, 0, 0)
.BackColor = RGB(256, 256, 256)
End With
arrCounter = arrCounter + 1
xDiff = xDiff + 24
Next k
Next j
''add code for form module
myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
myForm.codemodule.insertlines 2, "absDate = 0"
myForm.codemodule.insertlines 3, "Unload Me"
myForm.codemodule.insertlines 4, "End Sub"
myForm.codemodule.insertlines 5, ""
myForm.codemodule.insertlines 6, "Private Sub SpinButton1_SpinDown()"
myForm.codemodule.insertlines 7, "Dim newDate1 As Date"
myForm.codemodule.insertlines 8, " newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
myForm.codemodule.insertlines 9, " newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", -1, newDate1)"
myForm.codemodule.insertlines 10, " Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
myForm.codemodule.insertlines 11, " Call clearBoxes"
myForm.codemodule.insertlines 12, " Run fillCal(newDate1)"
myForm.codemodule.insertlines 13, "End Sub"
myForm.codemodule.insertlines 14, "Private Sub SpinButton1_SpinUp()"
myForm.codemodule.insertlines 15, "Dim newDate1 As Date"
myForm.codemodule.insertlines 16, " newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
myForm.codemodule.insertlines 17, " newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", 1, newDate1)"
myForm.codemodule.insertlines 18, " Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
myForm.codemodule.insertlines 19, " Call clearBoxes"
myForm.codemodule.insertlines 20, " Run fillCal(newDate1)"
myForm.codemodule.insertlines 21, "End Sub"
myForm.codemodule.insertlines 22, "Function dhDaysInMonth2(Optional dtmDate As Date = 0) As Integer"
myForm.codemodule.insertlines 23, " ' Return the number of days in the specified month. Written by Chip Pierson"
myForm.codemodule.insertlines 24, " If dtmDate = 0 Then"
myForm.codemodule.insertlines 25, " ' Did the caller pass in a date? If not, use"
myForm.codemodule.insertlines 26, " ' the current date."
myForm.codemodule.insertlines 27, " dtmDate = Date"
myForm.codemodule.insertlines 28, " End If"
myForm.codemodule.insertlines 29, " dhDaysInMonth2 = DateSerial(Year(dtmDate), _ "
myForm.codemodule.insertlines 30, " Month(dtmDate) + 1, 1) - _ "
myForm.codemodule.insertlines 31, " DateSerial(Year(dtmDate), Month(dtmDate), 1)"
myForm.codemodule.insertlines 32, "End Function"
myForm.codemodule.insertlines 33, "Public Sub UserForm_Activate()"
myForm.codemodule.insertlines 34, "Dim currentDate As Date"
myForm.codemodule.insertlines 35, ""
myForm.codemodule.insertlines 36, " For i = 1 To 42" & vbNewLine
myForm.codemodule.insertlines 37, " txt = txt & " & Chr(34) & "Private Sub lb_" & Chr(34) & " & i & " & Chr(34) & "_Click()" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 38, " txt = txt & " & Chr(34) & "Dim newDate As Date" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 39, " txt = txt & " & Chr(34) & "newDate = DateValue(Mid(Label1.Caption, 1, Len(Label1.Caption) - 5) &" & Chr(34) & " & Chr(34) & " & Chr(34) & Chr(34) & " & lb_" & " & i & " & Chr(34) & ".Caption & " & Chr(34) & " & Chr(34) & " & Chr(34) & ", " & Chr(34) & " & Chr(34) & " & Chr(34) & " & Right(Label1.Caption, 4))" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 40, " txt = txt & " & Chr(34) & "Label2.Caption = " & Chr(34) & " & Chr(34) & " & Chr(34) & "Date: " & Chr(34) & " & Chr(34) & " & Chr(34) & " & newDate" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 41, "txt = txt & " & Chr(34) & "End Sub" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 42, "Next i" & vbNewLine
myForm.codemodule.insertlines 43, ""
myForm.codemodule.insertlines 44, "Label2.Caption = Chr(34) & Chr(34) "
myForm.codemodule.insertlines 45, "currentDate = DateValue(Month(Date) & " & Chr(34) & " 1" & Chr(34) & " & " & Chr(34) & ", " & Chr(34) & " & Year(Date))"
myForm.codemodule.insertlines 46, "Run fillCal(currentDate)"
myForm.codemodule.insertlines 47, "End Sub"
myForm.codemodule.insertlines 48, "Function fillCal(startDate As Date)"
myForm.codemodule.insertlines 49, "Dim currentDayOfMonth As Integer, i As Integer"
myForm.codemodule.insertlines 50, "currentDayOfMonth = Day(Date)"
myForm.codemodule.insertlines 51, "Dim startCal As Date, currentMonth as Integer"
myForm.codemodule.insertlines 52, "Dim labelArray, sumVar3 As Long"
myForm.codemodule.insertlines 53, " Label2.Caption = " & Chr(34) & "" & Chr(34)
myForm.codemodule.insertlines 54, " labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
& Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
& "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ", _"
myForm.codemodule.insertlines 55, " " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
myForm.codemodule.insertlines 56, " " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
myForm.codemodule.insertlines 57, " Label1 = MonthName(Month(startDate)) & " & Chr(34) & " " & Chr(34) & " & Year(startDate)"
myForm.codemodule.insertlines 58, " sumVar3 = Weekday(startDate) - 1"
myForm.codemodule.insertlines 59, " "
myForm.codemodule.insertlines 60, " For i = LBound(labelArray) To UBound(labelArray)"
myForm.codemodule.insertlines 61, " Me.Controls(labelArray(i)).Caption = " & Chr(34) & "" & Chr(34) & ""
myForm.codemodule.insertlines 62, " Next i"
myForm.codemodule.insertlines 63, " "
myForm.codemodule.insertlines 64, " For i = 1 To dhDaysInMonth2(startDate)"
myForm.codemodule.insertlines 65, " Me.Controls(labelArray(sumVar3)).Caption = i"
myForm.codemodule.insertlines 66, " If currentDayOfMonth = i And month(Date) = Month(StartDate) And Year(Date) = Year(StartDate) Then"
myForm.codemodule.insertlines 67, " Me.Controls(labelArray(sumVar3)).BackColor = RGB(256, 0, 0)"
myForm.codemodule.insertlines 68, " Me.Controls(labelArray(sumVar3)).ForeColor = RGB(256, 256, 256)"
myForm.codemodule.insertlines 69, " Label2.Caption = " & Chr(34) & "Date: " & Chr(34) & " & DateValue(Month(startDate) & " & Chr(34) & "/" & Chr(34) & " & i & " & Chr(34) & "/" & Chr(34) & " & Year(startDate))"
myForm.codemodule.insertlines 70, " End If"
myForm.codemodule.insertlines 71, " sumVar3 = sumVar3 + 1"
myForm.codemodule.insertlines 72, " Next i"
myForm.codemodule.insertlines 73, " "
myForm.codemodule.insertlines 74, "End Function"
myForm.codemodule.insertlines 75, "Private Sub CommandButton2_Click()"
myForm.codemodule.insertlines 76, " absDate = Replace(Me.Label2.Caption, " & Chr(34) & "Date: " & Chr(34) & ", " & Chr(34) & Chr(34) & "):Unload Me"
myForm.codemodule.insertlines 77, "End Sub"
myForm.codemodule.insertlines 78, "Private Sub clearBoxes()"
myForm.codemodule.insertlines 79, "Dim labelArray"
myForm.codemodule.insertlines 80, " Label2.Caption = " & Chr(34) & "" & Chr(34)
myForm.codemodule.insertlines 81, " labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
& Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
& "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ", _"
myForm.codemodule.insertlines 82, " " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
myForm.codemodule.insertlines 83, " " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
myForm.codemodule.insertlines 84, " For i = lbound(labelArray) to ubound(labelArray)"
myForm.codemodule.insertlines 85, " Me.Controls(labelArray(i)).BackColor = RGB(256, 256, 256)"
myForm.codemodule.insertlines 86, " Me.Controls(labelArray(i)).ForeColor = RGB(0, 0, 0)"
myForm.codemodule.insertlines 87, " next i"
myForm.codemodule.insertlines 88, "End Sub"
' add click controls for date label boxes
Dim myCounter As Long
myCounter = 89
For i = 1 To 42
myForm.codemodule.insertlines myCounter, "Private Sub lb_" & i & "_Click()"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "Dim newDate As Date"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "Call clearBoxes"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "absDate = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & Chr(32) & Chr(34) & " & lb_" & i & ".Caption & " & Chr(34) & ", " & Chr(34) & Chr(38) & " Right(Label1.Caption, 4))"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "Label2.Caption = " & Chr(34) & "Date: " & Chr(34) & " & absDate" & vbNewLine
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "lb_" & i & ".backcolor = rgb(256,0,0)"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "lb_" & i & ".forecolor = rgb(256,256,256)"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "End Sub" & vbNewLine
myCounter = myCounter + 1
Next i
'Add and show new userform
absDate = Format(Date, "mm/dd/yyyy")
Set calendarForm = VBA.UserForms.Add(myForm.Name)
calendarForm.Show
If absDate <> 0 Then
' Here is where you put your code to to use the selected date
' whhich is in the global variabole "absDate"
startDate = absDate
Debug.Print "Your First Date is " & startDate
Else
Beep
MsgBox "You did not select a date"
GoTo endItAll
End If
endItAll:
' Uncomment the following line if you want to delete the form after using it
ThisWorkbook.VBProject.VBComponents.Remove myForm
End Sub
Function dhDaysInMonth(Optional dtmDate As Date = 0) As Integer
' Return the number of days in the specified month. Written by Chip Pierson
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhDaysInMonth2 = DateSerial(Year(dtmDate), _
Month(dtmDate) + 1, 1) - _
DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function
在 VBA Excel 模块中使用 DTPicker（日期选择器）元素会使您的工作无法共享。这发生在我身上很多次。我经常和朋友们分享我的作品，但是当他们遇到 DTPicker 缺少库问题时，他们无法继续。
安装 Microsoft Common Control 2 SP6 然后注册其服务并非适合所有人。所以，我没有使用 DTPicker 元素，而是开发了我自己的 Date Picker，它更方便、简单和适用。
这是表单文件的 link。
https://www.dropbox.com/s/bwxtkw03kytcv8v/Form%20Files.rar?dl=0
使用此表格的步骤
- 导入它
- 现在，在您的USERFORM 中，在日期区域（文本框）中，使用双击事件执行我的表单文件。
enter image description here
作为 DTPicker 控件的替代品，可以使用用户表单轻松地将日期添加到活动单元格。
工作表上任意单元格上 double-clicked 时显示日历表单。从用户窗体标题上的月份开始，根据用户的系统语言在组合框控件中列出月份。
用户窗体上单击按钮的 ControlTipText 值作为日期添加到活动单元格。
我需要在 Excel 2013 年添加日历日期选择器。
我发现 MonthView 和 DT Picker 不再出现在 ActiveX 菜单中，并且据称包含这些内容的 CAB 文件的链接不起作用。有说明文档，但是依赖了一个不存在的控件
我有一个 Excel 插件可以满足我的需求，但我想用 VBA 来完成它，而不是在每台将使用它的机器上安装插件。
我已经使用 mscomct2.ocx 文件在 excel 中使用日期选择器。 您需要注册它，然后才能轻松使用日期选择器
一旦您注册了 mscomct2.ocx 控件（您将需要在所有将使用此手册的计算机上注册此文件！)，您可以在工作表或用户窗体中添加以下控件之一：
- 日期和时间选择器（DTPicker），left/top 的屏幕截图
- MonthView、right/bottom 的屏幕截图
工作表 (ActiveX)
- 在“开发工具”选项卡的“控件”组中，单击“插入”，然后单击右下角
更多控件按钮。
- 向下滚动并 select Microsoft 日期和时间选择器控件 6.0 (SP6) 或 Microsoft MonthView 控件 6.0 (SP6) 然后单击确定。
- 当你退出设计模式时，点击DTPicker控件是这样的，而MonthView需要更多space:
用户窗体
- 在 UserForm selected 的工具箱中，右键单击“控件”选项卡的空白 space，单击“附加控件”
- 向下滚动并勾选 Microsoft 日期和时间选择器控件 6.0 (SP6) 或 Microsoft MonthView 控件 6.0 (SP6):
- 现在控件位于您的控件选项卡中以添加到 UserForms
- 用户窗体上控件的默认大小：
无论哪种方式，您都需要在单击这些控件时执行操作。
有些用户如果 Excel 格式不正确，可能无法使用您的 DatePicker。我开发的代码将创建一个 dateGetter 用户窗体，获取用户的日期 selection 作为全局变量，然后删除该窗体。它应该与大多数系统兼容，尽管我没有在我自己的系统上测试过它。试一试。如果它对你有用，请大声说出来....
2020 年 8 月： 修复了一个小故障 - 当 select 以 return 形式打开的原始日期是“00:00:00 AM”时 - 我将其修复为 return 显示的日期在 label2 标题中。
此外 - MSForms 引用对于 dateGetter() 子例程的正常工作是必需的，否则在声明表单 objects 时您会收到错误消息。我添加了另一个子例程，可以通过 VBA 代码添加该引用，或者在 VBA 编辑器中转到“工具 --> 引用”和 select MSForms 引用。您必须在尝试 运行 dateGetter 宏之前执行此操作。
Public absDate As Date ' This Public Variable is necessary to pass selected date
Sub setGUIDReferences()
' NOTE: The dateGetter() sub will not work until the MSForms Reference is added to this workbook project
' You can add the MSForms reference by running this sub first
' Or go to Tools --> References and select the MSForms reference there
' included below are several other common references you can use for other projects just uncomment them to add
' *************************************************************************************************************
On Error Resume Next
'ThisWorkbook.VBProject.References.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 0, 0 ' Visual Basic For Applications
'ThisWorkbook.VBProject.References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 0, 0 ' Microsoft Excel 16.0 Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 0, 0 ' OLE Automation
'ThisWorkbook.VBProject.References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 0, 0 ' Microsoft Office 16.0 Object Library
ThisWorkbook.VBProject.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 0, 0 ' Microsoft Forms 2.0 Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 0, 0 ' Microsoft HTML Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 0, 0 ' Microsoft Internet Controls
'ThisWorkbook.VBProject.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 0, 0 ' Microsoft Scripting Runtime
'ThisWorkbook.VBProject.References.AddFromGuid "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}", 0, 0 ' Microsoft Windows Common Controls-2 6.0 (SP6)
'ThisWorkbook.VBProject.References.AddFromGuid "{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}", 0, 0 ' Microsoft Access 16.0 Object Library
'ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0 ' Microsoft Visual Basic for Applications Extensibility 5.3
'ThisWorkbook.VBProject.References.AddFromGuid "{F5078F18-C551-11D3-89B9-0000F81FE221}", 0, 0 ' Microsoft MSXML2 for XML Scraping
On Error GoTo 0
End Sub
Sub dateGetter()
' This creates dategetter userform for those without access to date picker
' Bug Fixed: Aug 2020, Selecting Original Date was resulting in 12:00:00 AM
'*********
' Note: MSForms Reference in Tools menu must be added to workbook first before this calendar script will work
' You can add several commonly used references by running the "setGUIDReferences()" subroutine above.
' Or go to Tools --> References and select the MSForms reference there
'*********
Dim myForm As Object, calendarForm As Object, newLabel As MSForms.Label, newSpinner As MSForms.SpinButton
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
Dim NewListBox As MSForms.ListBox
Dim smallDayArray
Dim xDiff As Long
Dim smallTextArray
Dim startDate As Date
Dim endDate As Date
Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)
'Create the User Form
With myForm
.Properties("Caption") = "Select Date Range"
.Properties("Width") = 247.5
.Properties("Height") = 350
End With
'create button
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "CommandButton1"
.Top = 288
.Left = 138
.Width = 42
.Height = 24
.Font.Size = 10
.Font.Name = "Tahoma"
.Caption = "Cancel"
End With
'create button
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "CommandButton2"
.Top = 288
.Left = 186
.Width = 42
.Height = 24
.Font.Size = 10
.Font.Name = "Tahoma"
.Caption = "Select"
End With
'create frame
Set NewFrame = myForm.designer.Controls.Add("Forms.frame.1")
With NewFrame
.Name = "Frame1"
.Top = 54
.Left = 24
.Width = 192
.Height = 180
.Font.Size = 9
.Font.Name = "Tahoma"
End With
'Create label1
Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
With newLabel
.Name = "Label1"
.Top = 30
.Left = 30
.Width = 102
.Height = 18
.Font.Size = 12
.Font.Name = "Tahoma"
.ForeColor = RGB(128, 0, 0)
.BackColor = RGB(256, 256, 256)
.Caption = "November 2017"
End With
'Create label2
Set newLabel = myForm.designer.Controls.Add("Forms.Label.1")
With newLabel
.Name = "Label2"
.Top = 258
.Left = 36
.Width = 174
.Height = 18
.Font.Size = 12
.Font.Name = "Tahoma"
.ForeColor = RGB(0, 0, 0)
.Caption = "01/01/2017"
End With
'Create SpinButton1
Set newSpinner = myForm.designer.Controls.Add("Forms.spinbutton.1")
With newSpinner
.Name = "SpinButton1"
.Top = 24
.Left = 144
.Width = 12.75
.Height = 25
End With
'Create Calendar Header Labels
smallDayArray = Array("S", "M", "T", "W", "T", "F", "S")
smallTextArray = Array("day1", "day2", "day3", "day4", "day5", "day6", "day7")
xDiff = 18
For i = LBound(smallDayArray) To UBound(smallDayArray)
Set lbl = NewFrame.Controls.Add("Forms.Label.1")
With lbl
.Name = smallTextArray(i)
.Top = 6
.Left = xDiff
.Width = 12
.Height = 18
.Font.Size = 11
.Font.Name = "Tahoma"
.Caption = smallDayArray(i)
End With
xDiff = xDiff + 24
Next i
'Create Calendar boxes labels
arrCounter = 1
For j = 1 To 6
xDiff = 12
For k = 1 To 7
Set lbl = NewFrame.Controls.Add("Forms.Label.1")
With lbl
.Name = "lb_" & arrCounter
Select Case j
Case 1
.Top = 24
Case 2
.Top = 48
Case 3
.Top = 72
Case 4
.Top = 96
Case 5
.Top = 120
Case 6
.Top = 144
End Select
.Left = xDiff
.Width = 18
.Height = 18
.Font.Size = 11
.Font.Name = "Tahoma"
.Caption = " " & arrCounter
.ForeColor = RGB(128, 0, 0)
.BackColor = RGB(256, 256, 256)
End With
arrCounter = arrCounter + 1
xDiff = xDiff + 24
Next k
Next j
''add code for form module
myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
myForm.codemodule.insertlines 2, "absDate = 0"
myForm.codemodule.insertlines 3, "Unload Me"
myForm.codemodule.insertlines 4, "End Sub"
myForm.codemodule.insertlines 5, ""
myForm.codemodule.insertlines 6, "Private Sub SpinButton1_SpinDown()"
myForm.codemodule.insertlines 7, "Dim newDate1 As Date"
myForm.codemodule.insertlines 8, " newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
myForm.codemodule.insertlines 9, " newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", -1, newDate1)"
myForm.codemodule.insertlines 10, " Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
myForm.codemodule.insertlines 11, " Call clearBoxes"
myForm.codemodule.insertlines 12, " Run fillCal(newDate1)"
myForm.codemodule.insertlines 13, "End Sub"
myForm.codemodule.insertlines 14, "Private Sub SpinButton1_SpinUp()"
myForm.codemodule.insertlines 15, "Dim newDate1 As Date"
myForm.codemodule.insertlines 16, " newDate1 = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & " 1, " & Chr(34) & " & Right(Label1.Caption, 4))"
myForm.codemodule.insertlines 17, " newDate1 = DateAdd(" & Chr(34) & "m" & Chr(34) & ", 1, newDate1)"
myForm.codemodule.insertlines 18, " Label1.Caption = MonthName(Month(newDate1)) & " & Chr(34) & " " & Chr(34) & " & Year(newDate1)"
myForm.codemodule.insertlines 19, " Call clearBoxes"
myForm.codemodule.insertlines 20, " Run fillCal(newDate1)"
myForm.codemodule.insertlines 21, "End Sub"
myForm.codemodule.insertlines 22, "Function dhDaysInMonth2(Optional dtmDate As Date = 0) As Integer"
myForm.codemodule.insertlines 23, " ' Return the number of days in the specified month. Written by Chip Pierson"
myForm.codemodule.insertlines 24, " If dtmDate = 0 Then"
myForm.codemodule.insertlines 25, " ' Did the caller pass in a date? If not, use"
myForm.codemodule.insertlines 26, " ' the current date."
myForm.codemodule.insertlines 27, " dtmDate = Date"
myForm.codemodule.insertlines 28, " End If"
myForm.codemodule.insertlines 29, " dhDaysInMonth2 = DateSerial(Year(dtmDate), _ "
myForm.codemodule.insertlines 30, " Month(dtmDate) + 1, 1) - _ "
myForm.codemodule.insertlines 31, " DateSerial(Year(dtmDate), Month(dtmDate), 1)"
myForm.codemodule.insertlines 32, "End Function"
myForm.codemodule.insertlines 33, "Public Sub UserForm_Activate()"
myForm.codemodule.insertlines 34, "Dim currentDate As Date"
myForm.codemodule.insertlines 35, ""
myForm.codemodule.insertlines 36, " For i = 1 To 42" & vbNewLine
myForm.codemodule.insertlines 37, " txt = txt & " & Chr(34) & "Private Sub lb_" & Chr(34) & " & i & " & Chr(34) & "_Click()" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 38, " txt = txt & " & Chr(34) & "Dim newDate As Date" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 39, " txt = txt & " & Chr(34) & "newDate = DateValue(Mid(Label1.Caption, 1, Len(Label1.Caption) - 5) &" & Chr(34) & " & Chr(34) & " & Chr(34) & Chr(34) & " & lb_" & " & i & " & Chr(34) & ".Caption & " & Chr(34) & " & Chr(34) & " & Chr(34) & ", " & Chr(34) & " & Chr(34) & " & Chr(34) & " & Right(Label1.Caption, 4))" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 40, " txt = txt & " & Chr(34) & "Label2.Caption = " & Chr(34) & " & Chr(34) & " & Chr(34) & "Date: " & Chr(34) & " & Chr(34) & " & Chr(34) & " & newDate" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 41, "txt = txt & " & Chr(34) & "End Sub" & Chr(34) & " & vbNewLine" & vbNewLine
myForm.codemodule.insertlines 42, "Next i" & vbNewLine
myForm.codemodule.insertlines 43, ""
myForm.codemodule.insertlines 44, "Label2.Caption = Chr(34) & Chr(34) "
myForm.codemodule.insertlines 45, "currentDate = DateValue(Month(Date) & " & Chr(34) & " 1" & Chr(34) & " & " & Chr(34) & ", " & Chr(34) & " & Year(Date))"
myForm.codemodule.insertlines 46, "Run fillCal(currentDate)"
myForm.codemodule.insertlines 47, "End Sub"
myForm.codemodule.insertlines 48, "Function fillCal(startDate As Date)"
myForm.codemodule.insertlines 49, "Dim currentDayOfMonth As Integer, i As Integer"
myForm.codemodule.insertlines 50, "currentDayOfMonth = Day(Date)"
myForm.codemodule.insertlines 51, "Dim startCal As Date, currentMonth as Integer"
myForm.codemodule.insertlines 52, "Dim labelArray, sumVar3 As Long"
myForm.codemodule.insertlines 53, " Label2.Caption = " & Chr(34) & "" & Chr(34)
myForm.codemodule.insertlines 54, " labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
& Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
& "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ", _"
myForm.codemodule.insertlines 55, " " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
myForm.codemodule.insertlines 56, " " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
myForm.codemodule.insertlines 57, " Label1 = MonthName(Month(startDate)) & " & Chr(34) & " " & Chr(34) & " & Year(startDate)"
myForm.codemodule.insertlines 58, " sumVar3 = Weekday(startDate) - 1"
myForm.codemodule.insertlines 59, " "
myForm.codemodule.insertlines 60, " For i = LBound(labelArray) To UBound(labelArray)"
myForm.codemodule.insertlines 61, " Me.Controls(labelArray(i)).Caption = " & Chr(34) & "" & Chr(34) & ""
myForm.codemodule.insertlines 62, " Next i"
myForm.codemodule.insertlines 63, " "
myForm.codemodule.insertlines 64, " For i = 1 To dhDaysInMonth2(startDate)"
myForm.codemodule.insertlines 65, " Me.Controls(labelArray(sumVar3)).Caption = i"
myForm.codemodule.insertlines 66, " If currentDayOfMonth = i And month(Date) = Month(StartDate) And Year(Date) = Year(StartDate) Then"
myForm.codemodule.insertlines 67, " Me.Controls(labelArray(sumVar3)).BackColor = RGB(256, 0, 0)"
myForm.codemodule.insertlines 68, " Me.Controls(labelArray(sumVar3)).ForeColor = RGB(256, 256, 256)"
myForm.codemodule.insertlines 69, " Label2.Caption = " & Chr(34) & "Date: " & Chr(34) & " & DateValue(Month(startDate) & " & Chr(34) & "/" & Chr(34) & " & i & " & Chr(34) & "/" & Chr(34) & " & Year(startDate))"
myForm.codemodule.insertlines 70, " End If"
myForm.codemodule.insertlines 71, " sumVar3 = sumVar3 + 1"
myForm.codemodule.insertlines 72, " Next i"
myForm.codemodule.insertlines 73, " "
myForm.codemodule.insertlines 74, "End Function"
myForm.codemodule.insertlines 75, "Private Sub CommandButton2_Click()"
myForm.codemodule.insertlines 76, " absDate = Replace(Me.Label2.Caption, " & Chr(34) & "Date: " & Chr(34) & ", " & Chr(34) & Chr(34) & "):Unload Me"
myForm.codemodule.insertlines 77, "End Sub"
myForm.codemodule.insertlines 78, "Private Sub clearBoxes()"
myForm.codemodule.insertlines 79, "Dim labelArray"
myForm.codemodule.insertlines 80, " Label2.Caption = " & Chr(34) & "" & Chr(34)
myForm.codemodule.insertlines 81, " labelArray = Array(" & Chr(34) & "lb_1" & Chr(34) & ", " & Chr(34) & "lb_2" & Chr(34) & ", " & Chr(34) & "lb_3" & Chr(34) & ", " & Chr(34) & "lb_4" & Chr(34) & ", " & Chr(34) & "lb_5" _
& Chr(34) & ", " & Chr(34) & "lb_6" & Chr(34) & ", " & Chr(34) & "lb_7" & Chr(34) & ", " & Chr(34) & "lb_8" & Chr(34) & ", " & Chr(34) & "lb_9" & Chr(34) & ", " & Chr(34) _
& "lb_10" & Chr(34) & ", " & Chr(34) & "lb_11" & Chr(34) & ", " & Chr(34) & "lb_12" & Chr(34) & ", " & Chr(34) & "lb_13" & Chr(34) & ", " & Chr(34) & "lb_14" & Chr(34) & ", " & Chr(34) & "lb_15" & Chr(34) & ", _"
myForm.codemodule.insertlines 82, " " & Chr(34) & "lb_16" & Chr(34) & ", " & Chr(34) & "lb_17" & Chr(34) & ", " & Chr(34) & "lb_18" & Chr(34) & ", " & Chr(34) & "lb_19" & Chr(34) & ", " & Chr(34) & "lb_20" & Chr(34) & ", " & _
Chr(34) & "lb_21" & Chr(34) & ", " & Chr(34) & "lb_22" & Chr(34) & ", " & Chr(34) & "lb_23" & Chr(34) & ", " & Chr(34) & "lb_24" & Chr(34) & ", " & Chr(34) & "lb_25" & Chr(34) & ", " & _
Chr(34) & "lb_26" & Chr(34) & ", " & Chr(34) & "lb_27" & Chr(34) & ", " & Chr(34) & "lb_28" & Chr(34) & ", " & Chr(34) & "lb_29" & Chr(34) & ", " & Chr(34) & "lb_30" & Chr(34) & ", " & Chr(34) & "lb_31" & Chr(34) & ", _"
myForm.codemodule.insertlines 83, " " & Chr(34) & "lb_32" & Chr(34) & ", " & Chr(34) & "lb_33" & Chr(34) & ", " & Chr(34) & "lb_34" & Chr(34) & ", " & Chr(34) & "lb_35" & Chr(34) & ", " & Chr(34) & "lb_36" & Chr(34) & ", " & _
Chr(34) & "lb_37" & Chr(34) & ", " & Chr(34) & "lb_38" & Chr(34) & ", " & Chr(34) & "lb_39" & Chr(34) & ", " & Chr(34) & "lb_40" & Chr(34) & ", " & Chr(34) & "lb_41" & Chr(34) & ", " & Chr(34) & "lb_42" & Chr(34) & ")"
myForm.codemodule.insertlines 84, " For i = lbound(labelArray) to ubound(labelArray)"
myForm.codemodule.insertlines 85, " Me.Controls(labelArray(i)).BackColor = RGB(256, 256, 256)"
myForm.codemodule.insertlines 86, " Me.Controls(labelArray(i)).ForeColor = RGB(0, 0, 0)"
myForm.codemodule.insertlines 87, " next i"
myForm.codemodule.insertlines 88, "End Sub"
' add click controls for date label boxes
Dim myCounter As Long
myCounter = 89
For i = 1 To 42
myForm.codemodule.insertlines myCounter, "Private Sub lb_" & i & "_Click()"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "Dim newDate As Date"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "Call clearBoxes"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "absDate = DateValue(Left(Label1.Caption, Len(Label1.Caption) - 5) & " & Chr(34) & Chr(32) & Chr(34) & " & lb_" & i & ".Caption & " & Chr(34) & ", " & Chr(34) & Chr(38) & " Right(Label1.Caption, 4))"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "Label2.Caption = " & Chr(34) & "Date: " & Chr(34) & " & absDate" & vbNewLine
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "lb_" & i & ".backcolor = rgb(256,0,0)"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "lb_" & i & ".forecolor = rgb(256,256,256)"
myCounter = myCounter + 1
myForm.codemodule.insertlines myCounter, "End Sub" & vbNewLine
myCounter = myCounter + 1
Next i
'Add and show new userform
absDate = Format(Date, "mm/dd/yyyy")
Set calendarForm = VBA.UserForms.Add(myForm.Name)
calendarForm.Show
If absDate <> 0 Then
' Here is where you put your code to to use the selected date
' whhich is in the global variabole "absDate"
startDate = absDate
Debug.Print "Your First Date is " & startDate
Else
Beep
MsgBox "You did not select a date"
GoTo endItAll
End If
endItAll:
' Uncomment the following line if you want to delete the form after using it
ThisWorkbook.VBProject.VBComponents.Remove myForm
End Sub
Function dhDaysInMonth(Optional dtmDate As Date = 0) As Integer
' Return the number of days in the specified month. Written by Chip Pierson
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhDaysInMonth2 = DateSerial(Year(dtmDate), _
Month(dtmDate) + 1, 1) - _
DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function
在 VBA Excel 模块中使用 DTPicker（日期选择器）元素会使您的工作无法共享。这发生在我身上很多次。我经常和朋友们分享我的作品，但是当他们遇到 DTPicker 缺少库问题时，他们无法继续。
安装 Microsoft Common Control 2 SP6 然后注册其服务并非适合所有人。所以，我没有使用 DTPicker 元素，而是开发了我自己的 Date Picker，它更方便、简单和适用。
这是表单文件的 link。 https://www.dropbox.com/s/bwxtkw03kytcv8v/Form%20Files.rar?dl=0
使用此表格的步骤
- 导入它
- 现在，在您的USERFORM 中，在日期区域（文本框）中，使用双击事件执行我的表单文件。
enter image description here
作为 DTPicker 控件的替代品，可以使用用户表单轻松地将日期添加到活动单元格。
工作表上任意单元格上 double-clicked 时显示日历表单。从用户窗体标题上的月份开始，根据用户的系统语言在组合框控件中列出月份。
用户窗体上单击按钮的 ControlTipText 值作为日期添加到活动单元格。