'//按 ALT+F11 转到 vba 界面，
'//新建一个模块
'//将以下代码 COPY 进去 'ClientToScreen 需要使用
Public Type POINTAPI
x As Long
y As Long
End Type Public Enum TwipsTransfer
DIRECTION_VERTICAL = 1
DIRECTION_HORIZONTAL = 0
End Enum 'apiGetDeviceCaps 的参数
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90 'SetWindowPos wFlags 参数使用的常数
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const SWP_NOMOVE = &H2
Public Const SWP_DRAWFRAME = &H20
'相对位置转换为屏幕绝对位置
Public Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long '移动窗体，或者更改窗体在屏幕上的Z轴顺序
Public 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
Public Declare Function apiGetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Long) As Long
Public Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hwnd As Long, _
ByVal hdc As Long) As Long
'获取分辩率设置的 API
Public Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
'像素转换成缇，本站以前文章中已经介绍过了。
' 关于单位“缇”与“像素”的转换，以及缇与其他单位（例如：厘米）之间的转换《窗体》
' http://access911.net/index.asp?u1=a&u2=72FAB41E13DCE9F3
Public Function PixelsToTwips(ByVal pixels As Long, ByVal direction As TwipsTransfer) As Long
On Error GoTo PixelsToTwips_Err
Dim lngDeviceHandle As Long
Dim lngPixelsPerInch As Long
lngDeviceHandle = apiGetDC(0)
If direction = DIRECTION_HORIZONTAL Then '水平X方向
lngPixelsPerInch = apiGetDeviceCaps(lngDeviceHandle, LOGPIXELSX)
Else '垂直Y方向
lngPixelsPerInch = apiGetDeviceCaps(lngDeviceHandle, LOGPIXELSY)
End If
lngDeviceHandle = apiReleaseDC(0, lngDeviceHandle)
PixelsToTwips = pixels * 1440 / lngPixelsPerInch
PixelsToTwips_Exit:
On Error Resume Next
Exit Function
PixelsToTwips_Err:
MsgBox Err.Description, vbExclamation, "access911.net"
Resume PixelsToTwips_Exit
End Function
'缇转换为像素，本站以前文章中已经介绍过了。
' 关于单位“缇”与“像素”的转换，以及缇与其他单位（例如：厘米）之间的转换《窗体》
' http://access911.net/index.asp?u1=a&u2=72FAB41E13DCE9F3
Public Function TwipsToPixels(ByVal twips As Long, ByVal direction As TwipsTransfer) As Long
On Error GoTo TwipsToPixels_Err Dim lngDeviceHandle As Long
Dim lngPixelsPerInch As Long
lngDeviceHandle = apiGetDC(0)
If direction = DIRECTION_HORIZONTAL Then '水平X方向
lngPixelsPerInch = apiGetDeviceCaps(lngDeviceHandle, LOGPIXELSX)
Else '垂直Y方向
lngPixelsPerInch = apiGetDeviceCaps(lngDeviceHandle, LOGPIXELSY)
End If
lngDeviceHandle = apiReleaseDC(0, lngDeviceHandle)
TwipsToPixels = twips / 1440 * lngPixelsPerInch
TwipsToPixels_Exit:
On Error Resume Next
Exit Function
TwipsToPixels_Err:
MsgBox Err.Description, vbExclamation, "access911.net"
Resume TwipsToPixels_Exit
End Function
'===========================================================
' 过程及函数名： PopupCalendarForm
' 版本号 ： --
' 说明 ： 在单个窗体视图下，根据传入的 TextBox 对象的
' 位置打开预制的frmCalendarSelect 窗体，以简
' 化选择日期的操作且日期控件不占用当前窗体的空间。
' 必须预先创建并设置好 frmCalendarSelect 窗体，
' 具体代码请看本示例中的《frmCalendarSelect》
' 引用 ： --
' 输入参数 ： textBox ，文本框对象，按地址传递。当选择某个日期后
' 该日期将被赋值给 textBox 控件。frmCalendarSelect 窗体
' 也将停靠在 textBox 的下放。
' 输出值 ： --
' 返回值 ： --
' 调用演示 ： PopupCalendarForm Me.Text0
' 最后修改日期： 2008-2-2 23:36:00
' 示例地址 ： http://access911.net/?kbid;72FABE1E1ADCE9F3
' 作者 ： cg1
' 网站 ： http://access911.net
' 电子邮件 ： access911@gmail.com
' 版权 ： 作者保留一切权力，
' 请在公布本代码时将本段说明一起公布，谢谢！
'===========================================================
Public Function PopupCalendarForm(ByRef textBox As Control)
Dim p As POINTAPI
Dim frm As Form
Set frm = textBox.Parent
If isExistsSection(frm, acHeader) = True Then '需要考虑页眉的影响
p.y = TwipsToPixels(textBox.Top + textBox.Height + frm.Section(acHeader).Height, DIRECTION_VERTICAL)
Else
p.y = TwipsToPixels(textBox.Top + textBox.Height, DIRECTION_VERTICAL)
End If
If frm.RecordSelectors = True Then
p.x = TwipsToPixels(textBox.Left, DIRECTION_HORIZONTAL) + 15 '需要考虑记录选择器的影响
Else
p.x = TwipsToPixels(textBox.Left, DIRECTION_HORIZONTAL) - 8
End If
ClientToScreen textBox.Parent.hwnd, p
DoCmd.OpenForm "frmCalendarSelect"
DoCmd.MoveSize PixelsToTwips(p.x, DIRECTION_HORIZONTAL), PixelsToTwips(p.y, DIRECTION_VERTICAL)
'API SetWindowPos 也可以达到此效果
'SetWindowPos Forms("frmCalendarSelect").hwnd, 0, p.x + 14, p.y, 0, 0, SWP_NOSIZE
'告知日期选择窗体数据应该回送给哪个控件
Set Forms("frmCalendarSelect").ctl = textBox
End Function
'用错误陷阱判断某个节是否存在
Public Function isExistsSection(ByVal frm As Form, _
ByVal whichSection As AcSection) As Boolean
On Error GoTo isExistsSection_Err Dim s As Section
Set s = frm.Section(whichSection)
isExistsSection = True
Exit Function
isExistsSection_Err:
Select Case Err.Number
Case 2462 '不存在
isExistsSection = False
Case Else
isExistsSection = False
Debug.Print Err.Number, Err.Description
End Select
End Function
| 
1701906
