纯Access的日期控件

sxgaobo

谢谢楼主了！！！
如果月份能是中文的（一月、二月、......）就更好了啊！

caijianhua1978

支持一下，顶一下

c101

谢谢分享

sagemeyou

谢谢分享

ADAM

不足之处:日期窗未跟随点击按钮定位

chenzhirong2008

附随点击按钮定位的代码, 但个人觉得为这个功能带这么多代码不值得.
Public Function PositionFormRelativeToControl(frmName As String, ctl As Access.Control, Optional Position As Long = 0) As Boolean
Position:
' 0 = Underneath
' 1 = On Top
' 2 = Right side
' 3 = Left side
' 4 = Bottom Right Hand Corner

Dim m_hWndSection As Long

Dim frm As Access.Form

Dim hWndMDI As Long
Dim MDIborderX As Long
Dim MDIborderY As Long

Dim rc As RECT
Dim rcWin As RECT
Dim pt As POINTAPI
Dim lOffsetX As Long, lOffsetY As Long

Dim m_ScreenWidth As Long
Dim m_ScreenHeight As Long

Dim lStyle As Long

On Error Resume Next

DoCmd.OpenForm frmName
Set frm = Forms.Item(frmName)

If Not frm Is Nothing Then

    m_hWndSection = fFindSectionhWnd(ctl)

    GetScreenDPI
    m_ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
    m_ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
   
    Select Case Position
        
        Case 0
        lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 1
        lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (-frm.WindowHeight + ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 2
        lOffsetX = (ctl.Left + ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 3
        lOffsetX = (ctl.Left - frm.WindowWidth) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case 4
        lOffsetX = (ctl.Left + ctl.Width) / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
        
        Case Else
        lOffsetX = ctl.Left / (TWIPSPERINCH / m_ScreenXdpi)
        lOffsetY = (ctl.Top + ctl.Height) / (TWIPSPERINCH / m_ScreenYdpi)
        
    End Select
        
    lRet = GetWindowRect(m_hWndSection, rc)

    pt.X = lOffsetX + rc.Left&
    pt.Y = lOffsetY + rc.Top
   
    lRet = GetWindowRect(frm.hwnd, rcWin)
   
    With rcWin
        If m_ScreenWidth - pt.X < .Right - .Left Then
                pt.X = m_ScreenWidth - (.Right - .Left)
        ElseIf pt.X < 2 Then 'm_S
                pt.X = 2
        End If
            
        If m_ScreenHeight - pt.Y < .Bottom - .Top Then
            pt.Y = m_ScreenHeight - (.Bottom - .Top)
        ElseIf pt.Y < 2 Then
            pt.Y = 2
        End If
        
    End With
        
    If Not frm.PopUp = True Then

        hWndMDI = FindWindowEx(Application.hWndAccessApp, 0&, "MDIClient", TITLE)
        lRet = ScreenToClient(hWndMDI, pt)

        lRet = GetWindowRect(hWndMDI, rcWin)
        lRet = GetClientRect(hWndMDI, rc)
        MDIborderX = ((rcWin.Right - rcWin.Left) - (rc.Right - rc.Left))
        MDIborderY = ((rcWin.Bottom - rcWin.Top) - (rc.Bottom - rc.Top))
        
        lStyle = GetWindowLong(hWndMDI, GWL_STYLE)
        
        If lStyle And WS_HSCROLL Then
            MDIborderY = MDIborderY - GetSystemMetrics(SM_CYHSCROLL)
        End If
        
        If lStyle And WS_VSCROLL Then
            MDIborderX = MDIborderX - GetSystemMetrics(SM_CXVSCROLL)
        End If
        MDIborderX = MDIborderX / 2
        MDIborderY = MDIborderY / 2
    Else

        MDIborderX = GetSystemMetrics(SM_CXBORDER)
        MDIborderY = GetSystemMetrics(SM_CYBORDER)
    End If
   
    Call SetWindowPos(frm.hwnd, 0&, pt.X - MDIborderX, pt.Y - MDIborderY, 0, 0, SWP_NOSIZE)
   
End If

Set frm = Nothing

PositionFormRelativeToControl = True

End Function

Private Sub GetScreenDPI()
Dim lngDC As Long

lngDC = GetDC(0)
m_ScreenXdpi = apiGetDeviceCaps(lngDC, LOGPIXELSX)
m_ScreenYdpi = apiGetDeviceCaps(lngDC, LOGPIXELSY)

lngDC = ReleaseDC(0, lngDC)
End Sub

Private Function fFindSectionhWnd(ctl As Access.Control) As Long
On Error GoTo Err_fFindSectionhWnd
    Dim hWnd_LSB As Long
    Dim hWnd_Temp As Long
   
    Dim rc As RECT
    Dim pt As POINTAPI
   
    Dim SectionCounter As Long
    Dim ctr As Long

     Select Case ctl.Section
         Case acDetail   '0
             SectionCounter = 2
         Case acHeader   '1
             SectionCounter = 1
         Case acFooter   '2
             SectionCounter = 3
         Case Else
     End Select
    ctr = 1
    If TypeOf ctl.Parent Is Access.Page Then
        If TypeOf ctl.Parent.Parent Is Access.TabControl Then
            If TypeOf ctl.Parent.Parent.Parent Is Access.Form Then
                hWnd_LSB = apiGetWindow(ctl.Parent.Parent.Parent.hwnd, GW_CHILD)
            End If
        End If
    Else

        hWnd_LSB = apiGetWindow(ctl.Parent.hwnd, GW_CHILD)
    End If
    Do
        If fGetClassName(hWnd_LSB) = "OFormSub" Then
            If ctr = SectionCounter Then
                fFindSectionhWnd = hWnd_LSB
                Exit Function
            End If
            ctr = ctr + 1
        End If
        hWnd_LSB = apiGetWindow(hWnd_LSB, GW_HWNDNEXT)
    Loop While hWnd_LSB <> 0
    fFindSectionhWnd = 0
   
Exit_fFindSectionhWnd:
    Exit Function

Err_fFindSectionhWnd:
    MsgBox Err.Description
    Resume Exit_fFindSectionhWnd
   
End Function

Private Function fGetClassName(hwnd As Long)
Dim strBuffer As String
Dim lngLen As Long
Const MAX_LEN = 255
    strBuffer = Space$(MAX_LEN)
    lngLen = apiGetClassName(hwnd, strBuffer, MAX_LEN)
    If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function

chenzhirong2008

还有API 声明
Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
   
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function ScreenToClient Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function apiGetWindowLong Lib "user32" _
  Alias "GetWindowLongA" _
  (ByVal hwnd As Long, _
  ByVal nIndex As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long


Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long

Private Declare Function apiGetWindow Lib "user32" _
Alias "GetWindow" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) _
As Long

Private Declare Function apiGetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long
   
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" (ByVal hwnd1 As Long, ByVal hwnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


' Window Styles
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_CHILD = &H40000000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_DISABLED = &H8000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_GROUP = &H20000
Private Const WS_TABSTOP = &H10000

Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000

Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW

Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_CHILDWINDOW = (WS_CHILD)

Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_TRANSPARENT = &H20&


Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
Private Const GW_MAX = 5



Private Const GWL_HINSTANCE = (-6)
Private Const GWL_STYLE = (-16)

Private Const TWIPSPERINCH = 1440&

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const BITSPIXEL = 12

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200

Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER

Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const TITLE = ""

Private m_ScreenXdpi As Long
Private m_ScreenYdpi As Long

Private lRet As Long

易碎的玫瑰香水

学习一下

luke99

是好东西

c101

谢谢分享