EXCEL VBA 一键输入日期控件

!!!橄榄树

EXCEL VBA 一键输入日期控件
       VB 一键输入日期控件

EXCEL VBA一键输入日期控件编制介绍(1)

    一、软件目的
    因许多日历控件又大又不好用,一般要三至五次击键才能输入日期,本人独创自感应鼠标滚动循环输入数字文本框精美日历。鼠标移动至年或月框中, 滚动鼠标自感应循环输入数字,一键输入任意日期,极大提高日期输入速度。为了精益求精,请提改进建议,或提供更先进的本类控件。谢谢!!!
    二、软件设计涉及的知识点及难点
    1.日期函数      2.鼠标移动函数        3.月份自动感应鼠标滚动循环输入算法
    4.日期控件类组  5.窗体最小化至任务栏
    三、软件设计步骤
    1.插入窗体,窗体名称：精美日历,窗体如下图,插入控件,其中 2020  和 01  是文本框控件, 6个框架控件,其它全是标签控件。

!!!橄榄树

附件改进更新！

!!!橄榄树

陆续发表中

!!!橄榄树

    EXCEL VBA一键输入日期控件,是在十多年前的 VB一键输入日期控件的基础上转换而来的,VB和VBA有很多地方不同,特别是API和类函数转换难度较大,不知是否有朋友关心阅读,提问或提出宝贵意见,在我有空能回答的情况下,我会一一回答,谢谢！

EXCEL VBA一键输入日期控件编制介绍(2)

    三、软件设计步骤
    1.插入窗体,窗体名称：精美日历,窗体如下图,插入控件,其中 2020  和 01  是文本框控件, 6个框架控件,其它全是标签控件
    2.插入类模块,类模块名称：cLB, 类模块代码如下：

Public WithEvents MLB AsMSForms.Label '标签控件类

Public Sub Init(cLB AsMSForms.Label)

    Set MLB = cLB '初始化，将控件绑定到类

End Sub

Private Sub MLB_Click() '控件的Click事件

    LH = MLB.Caption: ID = Mid(MLB.Name, 6, 2)

    精美日历.日 = 精美日历.日 + 1

   '精美日历.日 = 精美日历.Controls("Label" & ID)

End Sub

Private SubClass_Terminate()

    Set MLB = Nothing '注销类

End Sub

    4. Workbook代码

Private Sub Workbook_Open()   

    精美日历.Show 0

End Sub

!!!橄榄树

EXCEL VBA一键输入日期控件编制介绍(3)

    三、软件设计步骤
    1.插入窗体,窗体名称：精美日历,窗体如下图,插入控件,其中 2020  和 01  是文本框控件, 6个框架控件,其它全是标签控件
    2.插入类模块,类模块名称：cLB
    3.插入普通模块,模块名称：模块1, 模块代码如下：
Private Declare PtrSafeFunction CallWindowProc Lib "user32" Alias _

    "CallWindowProcA" (ByVallpPrevWndFunc As Long, ByVal Hwnd As Long, _

    ByVal Msg As Long, ByVal wParam As Long,ByVal lParam As Long) As Long

Private Declare PtrSafeFunction SetWindowLong Lib "user32" Alias "SetWindowLongA"_  

(ByVal Hwnd As Long, ByVal nIndex AsLong, ByVal dwNewLong As Long) As Long

Private Const GWL_WNDPROC =-4

Private Const WM_MOUSEWHEEL= &H20A '滚动

Global lpPrevWndProcA AsLong

Public bMouseFlag As Boolean'鼠标事件激活标志

Public TX, IMG As String,UpDw, Labid, ID, LH, SB, SD As Integer '定义全局变量

Public Sub HookMouse(ByValHwnd As Long)

    lpPrevWndProcA = SetWindowLong(Hwnd,GWL_WNDPROC, AddressOf WindowProc)

End Sub

Public Sub UnHookMouse(ByValHwnd As Long)

    SetWindowLong Hwnd, GWL_WNDPROC,lpPrevWndProcA

End Sub

Private FunctionWindowProc(ByVal hw As Long, ByVal uMsg As Long, _

    ByVal wParam As Long, ByVal lParam As Long)As Long

    Select Case uMsg

        Case WM_MOUSEWHEEL '滚动

            Dim wzDelta, wKeys As Integer

            'wzDelta传递滚动的快慢，该值小于零表示滚轮向后滚动(朝用户方向)

            '大于零表示滚轮向前滚动（朝显示器方向）

            wzDelta = HIWORD(wParam)

            'wKeys指出是否有CTRL=8、SHIFT=4、鼠标键

            '(左=2、中=16、右=2、附加)按下，允许复合

            wKeys = LOWORD(wParam)

           '--------------------------------------------------

            If wzDelta < 0 Then '朝用户方向

                精美日历.DataDown

            Else                '朝显示器方向

                精美日历.DataUp

            End If

            '--------------------------------------------------

        Case Else

            WindowProc =CallWindowProc(lpPrevWndProcA, hw, uMsg, wParam, lParam)

    End Select

End Function

Private FunctionHIWORD(LongIn As Long) As Integer

     HIWORD = (LongIn And &HFFFF0000) \&H10000 '取出32位值的高16位

End Function

Private FunctionLOWORD(LongIn As Long) As Integer

     LOWORD = LongIn And &HFFFF&                '取出32位值的低16位

End Function

!!!橄榄树

附件改进更新！

!!!橄榄树

没有人看了, 就不再介绍了

xiakor

有人看的，楼主做得很棒。
我有个问题，如何通过修改日期范围，更改SQL查询结果？

X。P

楼主做得真是太好了，感觉压力好大，代码都不知道什么意思，

!!!橄榄树

附件改进更新！