EXCEL VBA开发单元格日历选择

一、需求概述

想在EXCEL中使用VBA开发一个日历选择，选中日期后自动将日期（如：2022年10月20日）输入到单元格中，并且弹窗在指定单元格的下方。

二、效果展示

以下是基于个人开发的一个任务日志案例。

 

三、代码开发如下（WIN10环境下）

'----------------------------------------------------------------------------------------------------------------------
'用来控制窗口跟随单元格位置
'如果系统是64位，则必须加上PtrSafe在Function前面，32位不用
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, _
        ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
'---------------------------------------------------------------------------------------------------------------------


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim lHwnd As Long
    Dim lDC As Long
    Dim lCaps As Long
    Dim lngLeft As Long
    Dim lngTop As Long
    Dim sngPiexlToPiont As Single
    Const lLogPixelsX = 88

    If Target.Count = 1 Then
        If Target.Row > 3 And Target.Row < 1000 And Target.Column = 2 Or Target.Column = 4 Then
'            Frm_Riqi.Show 0
'            Frm_Riqi.Top = Application.Top + Target.Top
'            Frm_Riqi.Left = Application.Left + Target.Left

'----------------------------------------------------------------------------------------------------------------------
'用来控制窗口跟随单元格位置
            lDC = GetDC(0)
            lCaps = GetDeviceCaps(lDC, lLogPixelsX)
            sngPiexlToPiont = 72 / lCaps * (100 / ActiveWindow.Zoom)
            lngLeft = CLng(ActiveWindow.PointsToScreenPixelsX(0) + (Target.Offset(1, 0).Left / sngPiexlToPiont))
            lngTop = CLng(ActiveWindow.PointsToScreenPixelsY(0) + (Target.Offset(1, 0).Top / sngPiexlToPiont))
            Frm_Riqi.StartUpPosition = 0
            lHwnd = FindWindow(vbNullString, Frm_Riqi.Caption)
            MoveWindow lHwnd, lngLeft, lngTop, 780, 750, True
'----------------------------------------------------------------------------------------------------------------------
            Frm_Riqi.Show 0
        Else
            Unload Frm_Riqi
        End If
    End If
End Sub

还要再开发设置一个日期的窗体，代码案例参考如下，可以直接下载使用：

https://download.csdn.net/download/shaochuan_2008/85425448https://download.csdn.net/download/shaochuan_2008/85425448