任何好的Form Resizing代码？ [英] Any good Form Resizing code?

查看：67 发布时间：2019/6/6 13:48:51 access

本文介绍了任何好的Form Resizing代码？的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我在Access 95 Developers手册中使用了一些旧代码。

代码工作得非常好，除了它似乎无法识别

宽屏幕和尺寸标签控件以便它们太大并且结束

掩盖了主窗体上的一些字段。

有没有好的代码可以用类似的方式工作

也可以a）在宽屏幕上拉伸表格宽度或b），依靠

高度而不是宽度来调整表格大小。我的VB技能不是很好，

所以我无法修改这段代码来做我想做的事。（我已经粘贴了

代码，我在下面使用）。

有什么想法吗？

谢谢！

选项比较数据库''使用数据库顺序进行字符串比较

选项明确

''来自Microsoft Access 95 Developer's Handbook

''由Litwin，Getz，Gilbert和Reddick（Sybex）

''版权所有1995.所有权利保留。

''存储矩形坐标。

类型glrTypeRect

X1长期

Y1 As Long

X2 As Long

Y2 As Long

结束类型

声明函数glr_apiIsIconic Lib " USER32" _

AliasIsIconic （ByVal hwnd As Long）As long

声明函数glr_apiGetDeviceCaps Lib" gdi32" _

Alias" GetDeviceCaps" （ByVal hdc As Long，_

ByVal nIndex As Long）As long

声明函数glr_apiGetWindowRect Lib" user32" _

Alias" GetWindowRect" （ByVal hwnd As Long，_

lpRect as glrTypeRect）As long

声明函数glr_apiGetParent Lib" user32" _

Alias" GetParent" （ByVal hwnd As Long）As Long

声明函数glr_apiGetClientRect Lib" user32" _

Alias" GetClientRect" （ByVal hwnd As Long，_

lpRect as glrTypeRect）As Long

声明函数glr_apiGetWindowLong Lib" user32" _

Alias" GetWindowLongA" （ByVal hwnd As Long，_

ByVal nIndex As Long）As long

声明函数glr_apiGetSystemMetrics Lib" user32" _

Alias" GetSystemMetrics" （ByVal nIndex As Long）As long

声明函数glr_apiGetSystemMenu Lib" user32" _

Alias" GetSystemMenu" （ByVal hwnd As Long，_

ByVal bRevert As Long）As long

声明函数glr_apiGetActiveWindow Lib" user32" _

Alias" GetActiveWindow" （）As Long

''================================ ================= ======================

''存储组/子表单尺寸。

类型glrTypeDimensions

sglLeft单身

sglTop单身

sglWidth单身

sglHeight单身

strCtlName As String

结束类型

''这些是Access中使用的类名。

Public Const glrcAccessClass =" OMain"

Public Const glrcMDIClientClass =" MDICLIENT"

Public Const glrcAccessDBCClass =" ODb"

Public Const glrcAccessFormClass =" OForm"

''Windows API声明。

声明函数glr_apiCreateIC Libgdi32 _

Alias" CreateICA" （ByVal lpDriverName As String，_

ByVal lpDeviceName As String，ByVal lpOutput As String，_

lpInitData As Any）As Long

声明函数glr_apiDeleteDC Lib" gdi32" _

Alias" DeleteDC" （ByVal hdc As Long）As long

声明函数glr_apiMoveWindow Lib" user32" _

Alias" MoveWindow" （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很长

声明函数glr_apiSetWindowLong Lib" user32" _

Alias" SetWindowLongA" （ByVal hwnd As Long，_

ByVal nIndex As Long，ByVal dwNewLong As Long）

声明函数glr_apiEnableMenuItem Lib" user32" _

Alias" EnableMenuItem" （ByVal hMenu As Long，_

ByVal wIDEnableItem As Long，ByVal wEnable as Long）As long

声明函数glr_apiGetWindow Lib" user32" _

Alias" GetWindow" （ByVal hwnd As Long，ByVal wCmd as Long）As long

声明函数glr_apiGetClassName Lib" user32" _

Alias" GetClassNameA" （ByVal hwnd As Long，_

ByVal lpClassName As String，ByVal nMaxCount As Long）As long

声明函数glr_apiFindWindow Lib" user32" _

Alias" FindWindowA" （ByVal lpClassName As String，_

ByVal lpWindowName As String）As long

声明函数glr_apiGetNextWindow Lib" user32" _

Alias" GetNextWindow" （ByVal hwnd As Long，_

ByVal wFlag As Long）As long

声明函数glr_apiSetFocus Lib" user32" _

Alias" SetFocus" （ByVal hwnd As Long）As Long

''从私人INI文件中获取一个字符串。返回复制到strReturned中的字节数

''，不包括尾随空值。

声明函数glr_apiGetPrivateProfileString Lib" kernel32" _

Alias" GetPrivateProfileStringA" （ByVal lpApplicationName As String，_

ByVal lpKeyName As String，ByVal lpDefault As String，_

ByVal lpReturnedString As String，ByVal nSize As Long，_

ByVal lpFileName As String）As long

''将字符串写入私有INI文件。如果

成功则返回非零值，

''否则返回0.

声明函数glr_apiWritePrivateProfileString Lib" ; KERNEL32" _

Alias" WritePrivateProfileStringA" （ByVal lpApplicationName As String，_

ByVal lpKeyName As String，ByVal lpString As String，ByVal lpFileName As

String）As Long

''这些功能实际上并没有使用

''但这里仅供参考。

''从WIN获取一个字符串。 INI。返回复制到

strReturned的字节数，

''不包括尾随空值。

声明函数glr_apiGetProfileString Lib" kernel32" _

Alias" GetProfileStringA" （ByVal lpglrcAppName As String，_

ByVal lpKeyName As String，ByVal lpDefault As String，_

ByVal lpReturnedString As String，ByVal nSize As Long）As Long

''从WIN.INI获取一个整数。返回它找到的整数，

''或intDefault中发送的值。

声明函数glr_apiGetProfileInt Lib" kernel32" _

Alias" GetProfileIntA" （ByVal lpglrcAppName As String，_

ByVal lpKeyName As String，ByVal nDefault As Long）As long

''给WIN.INI写一个字符串。如果成功则返回非零值，否则返回0.

声明函数WriteProfileString Lib" kernel32" _

Alias" WriteProfileStringA" （ByVal lpszSection As String，_

ByVal lpszKeyName As String，ByVal lpszString As String）As long

''从私有INI文件中获取一个整数。返回它找到的整数
，

''或intDefault中发送的值。

声明函数GetPrivateProfileInt Lib" kernel32" _

Alias" GetPrivateProfileIntA" （ByVal lpApplicationName As String，_

ByVal lpKeyName As String，ByVal nDefault As Long，_

ByVal lpFileName As String）As Long

''GetNextWindow（）常量

Public Const glrcGW_CHILD = 5

Public Const glrcGW_HWNDNEXT = 2

''动作常量

Public Const glrcMF_BYCOMMAND =& H0

Public Const glrcMF_DISABLED =& H2

Public Const glrcMF_ENABLED =& H0

Public Const glrcMF_GRAYED =& H1

''菜单项名称常量

Public Const glrcSC_SIZE =& HF000

Public Const glrcSC_MOVE =& HF010

Public Const glrcSC_MINIMIZE =& HF020

Public Const glrcSC_MAXIMIZE =& HF030

Public Const glrcSC_NEXTWINDOW =& HF040

Public Const glrcSC_CLOSE =& HF060

Public Const glrcSC_RESTORE =& HF120

''Windows API常数

公开Const glrcVERTRES = 10

Public Const glrcHORZRES = 8

Public Const glrcLOGPIXELSX = 88

Public Const glrcLOGPIXELSY = 90

''一般常量

Public Const glrcTwipsPerInch = 1440

Public Const glrcGWL_STYLE = -16

''Windows样式常量

Public Const glrcWS_CAPTION =& HC00000

''系统度量标准常数

Public Const glrcSM_CYCAPTION = 4

Public Const glrcSM_CXFULLSCREEN = 16

Public Const glrcSM_CYFULLSCREEN = 17

函数IsSubForm（frm As Form）As Boolean

''

''参数中引用的表格当前是作为子表单加载的吗？

''检查其Parent属性以查找。

''来自Microsoft Access 95 Developer's Handbook

''由Litwin，Getz，吉尔伯特和雷迪克（Sybex）

''版权所有1995.保留所有权利。

''在：

''frm：对相关表格的引用

''输出：

''返回值：如果表单是子表单则为True

''如果它是独立形式则为False />
Dim strName As String

On Error Resume Next

strName = frm.Parent.name

IsSubForm =（Err = 0）

On Error GoTo 0

结束功能

选项比较数据库''使用数据库顺序进行字符串比较
选项明确

''来自Microsoft Access 95 Developer's Handbook

''由Litwin，Getz，Gilbert和Reddick（ Sybex）

''版权所有1995.保留所有权利。

''不存在的常数，可能应该是。

Const acWindow = 7

Const acSizeToFit = 6

Const acDatasheetView = 2

''GetTwips的枚举常量（）

Const glrcXAxis = 0

Const glrcYAxis = 1

''The表格的最大尺寸为22英寸。

Const glrcMaxTwips = 22 * glrcTwipsPerInch

''这些常数不需要更改。

''1280x1024,1024x768使用12和12.

''640x480和800x600使用15和15.

''

Const glrcDesignXTwipsLoRes = 15

Const glrcDesignYTwipsLoRes = 15

Const glrcDesignXTwipsHiRes = 12

Const glrcDesignYTwipsHiRes = 12

''跟踪表单的上一个/原始大小。

''Dim rctOriginal As glrTypeRect

''错误常数

Const glrcErrDivisionByZero = 11

Const glrcErrInvalidProperty = 2455

私函数ChangeFont（Ctl As Control）为布尔值

''决定是否更改字体，

''基于控件类型。

Dim fDoit As Integer

fDoit = False

选择Case Ctl.ControlType

Case acTextBox，acComboBox，acListBox，acLabel，_

acCommandButton，acToggleButton

fDoit = True

Case Else

fDoit = False

结束选择

ChangeFont = fDoit

结束功能

私函数ChangeHeight（Ctl As Control）作为布尔值

''决定是否改变高度，

''基于控件类型。

Dim fDoit As Integer

fDoit = True

选择Case Ctl.ControlType

Case acCheckBox，acOptionButton，acPageBreak，acPage

fDoit = False

Case Else

fDoit = True
>
结束选择

ChangeHeight = fDoit

结束功能

私人功能FixGroups（frm As Form，aGroups（）作为glrTypeDimensions，

sglFactorX As Single，sglFactorY As Single）

''存储有关控件的信息

''包含其他控件（子表单/子组）。

''返回找到

''的这些控件的数量。

Dim intI As Integer

Dim fDoit As Boolean

Dim intGroups as Integer

intGroups = 0

for intI = 0 to frm.Count - 1

with frm（intI）

Select Case .ControlType

Case acOptionGroup，acSubform

fDoit = True

Case Else

fDoit = False

结束选择

如果fDoit那么

intGroups = intGroups + 1

ReDim保留aGroups（intGroups）

aGroups（intGroups）.strCtlName = .name

aGroups（ intGroups）.sglLeft = .Left * sglFactorX

aGroups（intGroups）.sglTop = .Top * sglFactorY

aGroups（intGroups）.sglWidth = .Width * sglFactorX
aGroups（ intGroups）.sglHeight = .Height * sglFactorY

结束如果

结束

下一步intI

FixGroups = intGroups

结束功能

Private Sub FixSections（frm As Form，sglFactorY As Single）

''循环通过表单的所有部分，

''最多5个部分，每个部分设置高度

''。如果某个部分不存在，只需保持

''即可。

Dim intI As Integer

Dim varTemp作为Variant

''表格中有5个可能的部分，

''但它们可能并非都在那里。

出错时继续

with frm

对于intI = 0到4

varTemp = .Section（intI）.Height * sglFactorY

.Section（intI）.Height = IIf（varTemp> glrcMaxTwips，

glrcMaxTwips，varTemp）

下一页intI

结束

结束子

私人子GetFormSize（frm为表格，rct为glrTypeRect）

' '用窗口的坐标填写rct。

Dim hWndParent As Long

Dim rctParent as glrTypeRect

''找到有问题的窗口的位置，与它的父窗口（访问桌面，

''MDIClient窗口）的关系，

'。

hWndParent = glr_apiGe tParent（frm.hwnd）

''获取当前窗口及其父窗口的坐标。

glr_apiGetWindowRect frm.hwnd，rct

''抓住表格弹出的情况（即

''其父级不是Access主窗口。）在那个

''的情况下，不要减去

''访问MDIClient窗口的坐标。

如果hWndParent<> Application.hWndAccessApp然后

glr_apiGetWindowRect hWndParent，rctParent

' '需要相对于父母的坐标为

glr_apiMoveWindow（）

''函数调用。

使用rct

.X1 = .X1 - rctParent.X1

.Y1 = .Y1 - rctParent.Y1

.X2 = .X2 - rctParent.X1

.Y2 = .Y2 - rctParent.Y1

结束

结束如果

结束子

Private Sub GetScreenScale（intX As Integer，intY As Integer，sglFactorX As

Single，sglFactorY As Single）

''In：intX，intY：x和y屏幕分辨率

''表单创建时。

''输出：sglFactorX，sglFactorY：缩放因子为

''x和y方向。

Dim intScreenX作为整数

Dim intScreenY作为Intege r $ />

Dim intTwipsPerPixelX作为整数

Dim intTwipsPerPixelY作为整数

Dim lngIC As Long

错误GoTo GetScreenScaleError

''获取查找屏幕信息所需的信息上下文。

lngIC = glr_apiCreateIC（" ; DISPLAY"，vbNullString，_

vbNullString，vbNullString）

''如果对CreateIC的调用没有失败，那么获取信息。

如果是lngIC<> 0然后

''在

''屏幕上找到两个方向的像素数，（640x480,800x600,1024x768,1280x1024？）。这个

''也考虑了任务栏的大小，不管是什么。

''。

intScreenX = glr_apiGetSystemMetrics（glrcSM_CXFULLSCREEN）

intScreenY = glr_apiGetSystemMetrics（glrcSM_CYFULLSCREEN）

''找到两个方向上每个像素的缇数。

intTwipsPerPixelX = glrcTwipsPerInch / glr_apiGetDeviceCaps（lngIC，

glrcLOGPIXELSX）

intTwipsPerPixelY = glrcTwipsPerInch / glr_apiGetDeviceCaps（lngIC，

glrcLOGPIXELSY）

''发布信息背景。

glr_apiDeleteDC lngIC

''获取当前屏幕尺寸与设计时间的比率

''屏幕尺寸。

sglFactorX = intScreenX / intX

sglFactorY = intScreenY / intY

''最后，考虑到显示器

''分辨率的差异。在640x480，你得到更多的每像素缇（15）

''而不是12更高的分辨率。

''注意：GetTwips总是采用X RESOLUTION作为其第一个

参数。

sglFactorX = sglFactorX *（intTwipsPerPixelX / GetTwips（intX，

glrcXAxis））

sglFactorY = sglFactorY *（intTwipsPerPixelY / GetTwips（intX，

glrcYAxis））

结束如果

GetScreenScaleExit：

退出Sub

GetScreenScaleError：

Select Case Err.Number

Case glrcErrDivisionByZero

''看起来你第一次打电话给'/ b $ b''Win95下的GetDeviceCaps你已经完成了分辨率的快速修改后，它会返回0 <屏幕大小为
''。这将有希望纠正

''这个问题。

恢复

Case Else

HandleError" GetScreenScale"， Err.Number，Err.Description

恢复GetScreenScaleExit

结束选择

结束子

私人函数GetTwips（intXResolution As Integer，intAxis As Integer）

''经验表明，缇/像素比率

''取决于屏幕分辨率。如果您发现这个

''在您的特定情况下不是真的，那么您需要修改

''此例程。

选择案例intXResolution

案例1024,1280

GetTwips = IIf（intAxis = glrcXAxis，_

glrcDesignXTwipsHiRes，glrcDesignYTwipsHiRes）

案例640,800

GetTwips = IIf（intAxis = glrcXAxis，_

glrcDesignXTwipsLoRes，glrcDesignYTwipsLoRes）

Case Else

''如果值无效，只需假设设计的使用

''高分辨率屏幕。这可以做的最糟糕的是导致

''图像有点小。

GetTwips = IIf（intAxis = glrcXAxis，_

glrcDesignXTwipsHiRes，glrcDesignYTwipsHiRes）

结束选择

结束函数

函数glrResizeForm（frm As Form，ByVal fDoResize As Variant，rctOriginal

作为glrTypeRect）

''从表单的Resize事件中调用。

''尝试调整表单的大小它的

''控件。如果

'表格的当前高度为0，或者它是标志性的，那就什么都不做。

''来自微软访问95 Developer's Handbook

''由Litwin，Getz，Gilbert和Reddick（Sybex）

''版权所有1995.保留所有权利。

''在：

''frm：对相关表格的引用

''fDoResize：是/否（实际上是调整大小，或者只跟踪

信息？）

''rctOriginal：原始坐标

''出：

''没什么

Dim rctNew as glrTypeRect

Dim rctClient as glrTypeRect

Dim varTemp As Variant

Dim intWidth As Integer

Dim intHeight As Integer

Dim sglFactorX As Single

Dim sglFactorY As Single

出现错误GoTo glrResizeWindowError

''确保用户没有调整此尺寸

到小块。如果客户区域的高度为0，那么它是时候调用它了。

glr_apiGetClientRect frm.hwnd，rctNew

intHeight =（rctNew.Y2 - rctNew.Y1）

如果intHeight = 0或glr_apiIsIconic（frm.hwnd）那么

退出函数

结束如果

''获取当前宽度。已经找到了

''当前的高度。

intWidth =（rctNew.X2 - rctNew.X1）

''Calc给定当前

''高度/宽度和之前的高度/宽度的比例因子。

''可能是rctOriginal还没有

''已初始化，因此错误陷阱。

sglFactorX = intWidth /（rctOriginal.X2 - rctOriginal.X1）

sglFactorY = intHeight / （rctOriginal.Y2 - rctOriginal.Y1）

sglFactorOK：

''存储当前值为

''下次通过这里。

使用rctOriginal

.X1 = rctNew.X1

.X2 = rctNew.X2

.Y1 = rctNew.Y1

.Y2 = rctNew.Y2

结束

''如果比率为1，那么'''什么都不做。

如果（sglFactorX<> 1）或（sglFactorY<> 1）那么

''如果你真的想做一些调整大小，现在就做。

如果是fDo调整大小然后

SetFormSize frm，sglFactorX，sglFactorY，rctNew，False

结束如果

结束如果

glrResizeWindow退出：

退出函数

glrResizeWindowError：

如果Err = glrcErrDivisionByZero那么

sglFactorX = 1

sglFactorY = 1

恢复sglFactorOK

否则

HandleError" glrResizeForm"，Err.Number， Err.Description

继续下一步

结束如果

结束功能

函数glrScaleForm（frm As Form，intX As Integer，intY As Integer，

rctOriginal As glrTypeRect）

''从表格的公开赛中调用。

''尝试适当缩放表单

''对于给定的屏幕尺寸，相比

''到它设计的尺寸屏幕。

''来自Microsoft Access 95 Developer's Handbook

''由Litwin，Getz，Gilbert和Red提供迪克（Sybex）

''版权所有1995.保留所有权利。

''

''在：

''frm：对相关表格的引用

''intX：表单为

设计的水平屏幕分辨率。

''intY：表格为

设计的垂直屏幕分辨率。

''rctOriginal：原始坐标

''

''出：

''没什么

''评论：

''使用这样的函数调用：

''intRetval = glrScaleForm（Me，640,480，rctOriginal）

''自动缩放以640x480分辨率创建的表格。

Dim intTwipsPerPixelX作为整数

Dim intTwipsPerPixelY作为整数

Dim intScreenX作为整数

Dim intScreenY作为整数

Dim sglFactorX单身

Dim sglFactorY单身

GetScreenScale intX，intY，sglFactorX，sglFactorY

''此表单是否重新调整，

''你需要存储当前尺寸

''以后再说。你必须在这里调用GetFormSize

''而不是glr_apiGetClientRect的原因是

''你需要屏幕定位信息

''你不能用GetClientRect获得。

GetFormSize frm，rctOriginal

''如果x和y因子都是1，那么'什么都没有

''要做，所以滚到这里。

如果（sglFactorX = 1）和（sglFactorY = 1）那么退出功能

''如果你不想扩展表格（它们是在比当前设备更低分辨率的设备上创建的），但只有

''缩小（它们是在比现有设备更高分辨率的设备上创建的）b / b''，然后取消注释下一行。

''if（sglFactorX > 1）和（sglFactorY> 1）然后退出Sub

DoCmd.RepaintObject

SetFormSize frm，sglFactorX，sglFactorY，rctOriginal，True

结束功能

Private Sub HandleError（strFunction As String，intErr As Integer，strError

As String）

MsgBox" Error：" &安培; strError& " （& intErr&"）"，vbExclamation，

strFunction

End Sub

Private Sub SetFormSize （frm As Form，sglFactorX As Single，sglFactorY As

Single，rct As glrTypeRect，fMove As Integer）

''实际做的工作是调整所有控件

''在给定的表单上，然后调整表格大小

''本身。

Dim intTemp As Integer

Dim intWidth As Integer

Dim intHeight As Integer

Dim Ctl As Control

Dim sglFontSize As Single

Dim intI As Integer

Dim intGroups As Integer

Dim aGroups（）as glrTypeDimensions

Dim colGroups As New Collection

Dim varTemp As Variant

On Error GoTo SetFormSizeError

DoCmd.Hourglass True

frm.Painting = False

''如果表格垂直增长，那么需要

''修复s现在的高度。如果它正在缩小，

''在您放置控件后修正高度。

''表格宽度也一样。

如果sglFactorY> 1然后

''修正所有部分高度。

FixSections frm，sglFactorY

varTemp = frm.Width * sglFactorX

如果varTemp> glrcMaxTwips然后

frm.Width = glrcMaxTwips

否则

frm.Width = varTemp

结束如果

结束如果

''现在处理所有控件

''首先处理并处理所有组和子表单。

intGroups = FixGroups（frm，aGroups（），sglFactorX，sglFactorY）

''现在回去处理所有其他控件。 />
每个Ctl In frm.Controls

选择Case Ctl.ControlType

Case acOptionGroup

GoTo NextCtl

案例acSubform

''如果你有一个子表格，那么递归到这个

''程序再次，处理

''子窗体内的所有控件。

SetFormSize Ctl.Form，sglFactorX，sglFactorY，rct，False

GoTo NextCtl

案例acPage

''一个acPage，是标签控件上的'标签页'

' '''标签页那么..不要为调整标签页被当标签控件本身的大小调整

选项卡控制

自动调整大小。如果选项卡页面需要调整大小，则选项卡控件将自动调整大小以匹配页面大小（即选项卡控件

调整大小增加页面大小，然后页面调整大小

''增加tabcontrol大小，然后下一页是

调整大小，再次调整大小等等等等。 ...

''标签控件会在每个页面上增长X倍）

GoTo NextCtl

结束选择

''因此控件不是子表单而且它不是一个组。

''因此，只需将其缩放到正确的大小。

''首先，修正字体，如果此控件有字体

''需要修复。

如果ChangeFont（Ctl）然后

sglFontSize = Ctl.FontSize * sglFactorY

Else

sglFontSize = -1

End如果

''设置顶部，左侧和宽度值。

如果是frm.CurrentView< ;> acDatasheetView然后

Ctl.Top = Ctl.Top * sglFactorY

Ctl.Left = Ctl.Left * sglFactorX

Ctl.Width = Ctl。宽度* sglFactorX

结束如果

''更改高度，如果需要的话。

如果ChangeHeight（Ctl））然后

Ctl.Height = Ctl.Height * sglFactorY

结束如果

''只尝试更改字体大小对于

''某些类型的控件。

如果sglFontSize> = 1并且sglFontSize< = 127那么

Ctl.FontSize = sglFontSize

结束如果

NextCtl：

Next Ctl

''如果表格垂直缩小，现在所有的控件已经放置了

'，修正了

''部分的高度。表格宽度也是如此。

如果sglFactorY< 1然后

''修正所有部分高度。

FixSections frm，sglFactorY

frm.Width = frm.Width * sglFactorX

结束如果

''通过并修复选项组/子表单，

''可能因更改而失真

''内部控制。

for intI = 1 to intGroups

with frm（aGroups（intI）.strCtlName）

.Top = aGroups（intI）.sglTop

.Left = aGroups（intI）.sglLeft

.Width = aGroups（intI）.sglWidth

.Height = aGroups（intI）.sglHeight

结束

下一页intI

如果fMove那么

intWidth = Int((rct.X2 - rct.X1) * sglFactorX)

intHeight = Int((rct.Y2 - rct.Y1) * sglFactorY)

rct.X1 = Int(rct.X1 * sglFactorX)

rct.Y1 = Int(rct.Y1 * sglFactorY)

rct.X2 = rct.X1 + intWidth

rct.Y2 = rct.Y1 + intHeight

intTemp = glr_apiMoveWindow(f rm.hwnd, rct.X1, rct.Y1, intWidth,

intHeight, True)

’’ Use the Window-Size To Fit menu item.

DoCmd.DoMenuItem acFormBar, acWindow, acSizeToFit, , acMenuVer70

End If

SetFormSizeExit:

frm.Painting = True

DoCmd.Hourglass False

Exit Sub

SetFormSizeError:

Select Case Err

Case glrcErrInvalidProperty

Resume Next

Case Else

’’HandleError "SetFormSize", Err.Number, Error.Description

Resume Next

End Select

End Sub

I have some old code that I use from the Access 95 Developers handbook. The
code works very well, with the exception that it doesn''t seem to recognize
wide screens, and sizes tab controls so that they are too big and wind up
covering up some of the fields on the main form.

Is there any good code out there that works in a similar fashion that will
also either a) stretch the form width wise on widescreens or b), rely on
height rather than width to resize the form. My VB skill isn''t that great,
so I''m not able to modify this code to do what I want. (I''ve pasted the
code I''m using below).

Any ideas?

Thanks!

Option Compare Database ''Use database order for string comparisons
Option Explicit

'' From Microsoft Access 95 Developer''s Handbook
'' by Litwin, Getz, Gilbert, and Reddick (Sybex)
'' Copyright 1995. All rights reserved.

'' Store rectangle coordinates.
Type glrTypeRect
X1 As Long
Y1 As Long
X2 As Long
Y2 As Long
End Type

Declare Function glr_apiIsIconic Lib "user32" _
Alias "IsIconic" (ByVal hwnd As Long) As Long

Declare Function glr_apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long

Declare Function glr_apiGetWindowRect Lib "user32" _
Alias "GetWindowRect" (ByVal hwnd As Long, _
lpRect As glrTypeRect) As Long

Declare Function glr_apiGetParent Lib "user32" _
Alias "GetParent" (ByVal hwnd As Long) As Long

Declare Function glr_apiGetClientRect Lib "user32" _
Alias "GetClientRect" (ByVal hwnd As Long, _
lpRect As glrTypeRect) As Long

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

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

Declare Function glr_apiGetSystemMenu Lib "user32" _
Alias "GetSystemMenu" (ByVal hwnd As Long, _
ByVal bRevert As Long) As Long

Declare Function glr_apiGetActiveWindow Lib "user32" _
Alias "GetActiveWindow" () As Long

''================================================= ======================

'' Store group/subform dimensions.
Type glrTypeDimensions
sglLeft As Single
sglTop As Single
sglWidth As Single
sglHeight As Single
strCtlName As String
End Type

'' These are the class names used in Access.
Public Const glrcAccessClass = "OMain"
Public Const glrcMDIClientClass = "MDICLIENT"
Public Const glrcAccessDBCClass = "ODb"
Public Const glrcAccessFormClass = "OForm"

'' Windows API declarations.
Declare Function glr_apiCreateIC Lib "gdi32" _
Alias "CreateICA" (ByVal lpDriverName As String, _
ByVal lpDeviceName As String, ByVal lpOutput As String, _
lpInitData As Any) As Long

Declare Function glr_apiDeleteDC Lib "gdi32" _
Alias "DeleteDC" (ByVal hdc As Long) As Long

Declare Function glr_apiMoveWindow Lib "user32" _
Alias "MoveWindow" (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

Declare Function glr_apiSetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare Function glr_apiEnableMenuItem Lib "user32" _
Alias "EnableMenuItem" (ByVal hMenu As Long, _
ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long

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

Declare Function glr_apiGetClassName Lib "user32" _
Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Declare Function glr_apiFindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Declare Function glr_apiGetNextWindow Lib "user32" _
Alias "GetNextWindow" (ByVal hwnd As Long, _
ByVal wFlag As Long) As Long

Declare Function glr_apiSetFocus Lib "user32" _
Alias "SetFocus" (ByVal hwnd As Long) As Long

'' Get a string from a private INI file. Returns the number of bytes
'' copied into strReturned, not including the trailing null.
Declare Function glr_apiGetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

'' Write a string to a private INI file. Returns a non-zero value if
successful,
'' otherwise it returns a 0.

Declare Function glr_apiWritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As
String) As Long

'' These functions aren''t actually used
'' but are provided here for reference only.

'' Get a string from WIN.INI. Returns the number of bytes copied into
strReturned,
'' not including the trailing null.
Declare Function glr_apiGetProfileString Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpglrcAppName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long) As Long

'' Get an integer from WIN.INI. Returns either the integer it found,
'' or the value sent in intDefault.
Declare Function glr_apiGetProfileInt Lib "kernel32" _
Alias "GetProfileIntA" (ByVal lpglrcAppName As String, _
ByVal lpKeyName As String, ByVal nDefault As Long) As Long

'' Write a string to WIN.INI. Returns a non-zero value if successful,
'' otherwise it returns a 0.
Declare Function WriteProfileString Lib "kernel32" _
Alias "WriteProfileStringA" (ByVal lpszSection As String, _
ByVal lpszKeyName As String, ByVal lpszString As String) As Long

'' Get an integer from a private INI file. Returns either the integer it
found,
'' or the value sent in intDefault.
Declare Function GetPrivateProfileInt Lib "kernel32" _
Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As String, ByVal nDefault As Long, _
ByVal lpFileName As String) As Long

'' GetNextWindow() constants
Public Const glrcGW_CHILD = 5
Public Const glrcGW_HWNDNEXT = 2

'' Action constants
Public Const glrcMF_BYCOMMAND = &H0
Public Const glrcMF_DISABLED = &H2
Public Const glrcMF_ENABLED = &H0
Public Const glrcMF_GRAYED = &H1

'' Menu item name constants
Public Const glrcSC_SIZE = &HF000
Public Const glrcSC_MOVE = &HF010
Public Const glrcSC_MINIMIZE = &HF020
Public Const glrcSC_MAXIMIZE = &HF030
Public Const glrcSC_NEXTWINDOW = &HF040
Public Const glrcSC_CLOSE = &HF060
Public Const glrcSC_RESTORE = &HF120

'' Windows API Constants
Public Const glrcVERTRES = 10
Public Const glrcHORZRES = 8
Public Const glrcLOGPIXELSX = 88
Public Const glrcLOGPIXELSY = 90

'' General Constants
Public Const glrcTwipsPerInch = 1440

'' GetWindowLong Constant
Public Const glrcGWL_STYLE = -16

'' Windows Style constant
Public Const glrcWS_CAPTION = &HC00000

'' System Metrics Constant
Public Const glrcSM_CYCAPTION = 4
Public Const glrcSM_CXFULLSCREEN = 16
Public Const glrcSM_CYFULLSCREEN = 17

Function IsSubForm(frm As Form) As Boolean
'' Is the form referenced in the
'' parameter currently loaded as a subform?
'' Check its Parent property to find out.

'' From Microsoft Access 95 Developer''s Handbook
'' by Litwin, Getz, Gilbert, and Reddick (Sybex)
'' Copyright 1995. All rights reserved.

'' In:
'' frm: a reference to the form in question
'' Out:
'' Return value: True if the form is a subform
'' False if it''s a standalone form
Dim strName As String
On Error Resume Next
strName = frm.Parent.name
IsSubForm = (Err = 0)
On Error GoTo 0
End Function

Option Compare Database ''Use database order for string comparisons
Option Explicit

'' From Microsoft Access 95 Developer''s Handbook
'' by Litwin, Getz, Gilbert, and Reddick (Sybex)
'' Copyright 1995. All rights reserved.

'' Constants that aren''t there, that probably should be.
Const acWindow = 7
Const acSizeToFit = 6
Const acDatasheetView = 2

'' Enumerated constants for GetTwips()
Const glrcXAxis = 0
Const glrcYAxis = 1

'' The maximum size for a form is 22 inches.
Const glrcMaxTwips = 22 * glrcTwipsPerInch

'' These constants should not require changing.
'' 1280x1024, 1024x768 use 12 and 12.
'' 640x480 and 800x600 use 15 and 15.
''
Const glrcDesignXTwipsLoRes = 15
Const glrcDesignYTwipsLoRes = 15
Const glrcDesignXTwipsHiRes = 12
Const glrcDesignYTwipsHiRes = 12

'' Keep track of the previous/original size for the form.
'' Dim rctOriginal As glrTypeRect

'' Error constants
Const glrcErrDivisionByZero = 11
Const glrcErrInvalidProperty = 2455

Private Function ChangeFont(Ctl As Control) As Boolean

'' Decide whether or not to change the font,
'' based on the control type.

Dim fDoit As Integer
fDoit = False
Select Case Ctl.ControlType
Case acTextBox, acComboBox, acListBox, acLabel, _
acCommandButton, acToggleButton
fDoit = True
Case Else
fDoit = False
End Select
ChangeFont = fDoit
End Function

Private Function ChangeHeight(Ctl As Control) As Boolean

'' Decide whether or not to change the height,
'' based on the control type.

Dim fDoit As Integer
fDoit = True
Select Case Ctl.ControlType
Case acCheckBox, acOptionButton, acPageBreak, acPage
fDoit = False
Case Else
fDoit = True
End Select
ChangeHeight = fDoit
End Function

Private Function FixGroups(frm As Form, aGroups() As glrTypeDimensions,
sglFactorX As Single, sglFactorY As Single)

'' Store away information about controls that
'' contain other controls (subforms/subgroups).
'' Return the number of these controls that
'' were found.

Dim intI As Integer
Dim fDoit As Boolean
Dim intGroups As Integer

intGroups = 0
For intI = 0 To frm.Count - 1
With frm(intI)
Select Case .ControlType
Case acOptionGroup, acSubform
fDoit = True
Case Else
fDoit = False
End Select
If fDoit Then
intGroups = intGroups + 1
ReDim Preserve aGroups(intGroups)

aGroups(intGroups).strCtlName = .name
aGroups(intGroups).sglLeft = .Left * sglFactorX
aGroups(intGroups).sglTop = .Top * sglFactorY
aGroups(intGroups).sglWidth = .Width * sglFactorX
aGroups(intGroups).sglHeight = .Height * sglFactorY
End If
End With
Next intI
FixGroups = intGroups
End Function

Private Sub FixSections(frm As Form, sglFactorY As Single)

'' Loop through all the sections of the form,
'' up to 5 sections, setting the height of
'' each. If a section isn''t there, just keep
'' on going.

Dim intI As Integer
Dim varTemp As Variant

'' There are 5 possible sections in a form,
'' but they might not all be there.
On Error Resume Next
With frm
For intI = 0 To 4
varTemp = .Section(intI).Height * sglFactorY
.Section(intI).Height = IIf(varTemp > glrcMaxTwips,
glrcMaxTwips, varTemp)
Next intI
End With
End Sub

Private Sub GetFormSize(frm As Form, rct As glrTypeRect)

'' Fill in rct with the coordinates of the window.

Dim hWndParent As Long
Dim rctParent As glrTypeRect

'' Find the position of the window in question, in
'' relation to its parent window (the Access desktop,
'' the MDIClient window).
hWndParent = glr_apiGetParent(frm.hwnd)

'' Get the coordinates of the current window and its parent.
glr_apiGetWindowRect frm.hwnd, rct

'' Catch the case where the form is Popup (that is,
'' its parent is NOT the Access main window.) In that
'' case, don''t subtract off the coordinates of the
'' Access MDIClient window.
If hWndParent <> Application.hWndAccessApp Then
glr_apiGetWindowRect hWndParent, rctParent

'' Subtract off the left and top parent coordinates, since you
'' need coordinates relative to the parent for the
glr_apiMoveWindow()
'' function call.
With rct
.X1 = .X1 - rctParent.X1
.Y1 = .Y1 - rctParent.Y1
.X2 = .X2 - rctParent.X1
.Y2 = .Y2 - rctParent.Y1
End With
End If
End Sub

Private Sub GetScreenScale(intX As Integer, intY As Integer, sglFactorX As
Single, sglFactorY As Single)
'' In: intX, intY: x and y screen resolutions
'' when the form was created.
'' Out: sglFactorX, sglFactorY: scaling factors for
'' the x and y directions.

Dim intScreenX As Integer
Dim intScreenY As Integer

Dim intTwipsPerPixelX As Integer
Dim intTwipsPerPixelY As Integer

Dim lngIC As Long

On Error GoTo GetScreenScaleError

'' Get the information context you need to find the screen info.
lngIC = glr_apiCreateIC("DISPLAY", vbNullString, _
vbNullString, vbNullString)

'' If the call to CreateIC didn''t fail, then get the info.
If lngIC <> 0 Then
'' Find the number of pixels in both directions on the
'' screen, (640x480, 800x600, 1024x768, 1280x1024?). This
'' also takes into account the size of the task bar, whereever
'' it is.
intScreenX = glr_apiGetSystemMetrics(glrcSM_CXFULLSCREEN)
intScreenY = glr_apiGetSystemMetrics(glrcSM_CYFULLSCREEN)

'' Find the number of twips per pixel in both directions.
intTwipsPerPixelX = glrcTwipsPerInch / glr_apiGetDeviceCaps(lngIC,
glrcLOGPIXELSX)
intTwipsPerPixelY = glrcTwipsPerInch / glr_apiGetDeviceCaps(lngIC,
glrcLOGPIXELSY)

'' Release the information context.
glr_apiDeleteDC lngIC

'' Get the ratio of the current screen size to the design-time
'' screen size.

sglFactorX = intScreenX / intX
sglFactorY = intScreenY / intY

'' Finally, take into account the differences in the display
'' resolutions. At 640x480, you get more twips per pixel (15)
'' as opposed to 12 at higher resolutions.
'' Note: GetTwips always takes the X RESOLUTION as its first
parameter.
sglFactorX = sglFactorX * (intTwipsPerPixelX / GetTwips(intX,
glrcXAxis))
sglFactorY = sglFactorY * (intTwipsPerPixelY / GetTwips(intX,
glrcYAxis))
End If

GetScreenScaleExit:
Exit Sub

GetScreenScaleError:
Select Case Err.Number
Case glrcErrDivisionByZero
'' It seems that the first time you call
'' GetDeviceCaps under Win95 after you''ve done
'' a quick change on the resolution, it returns 0
'' for the screen size. This will hopefully correct
'' that problem.
Resume
Case Else
HandleError "GetScreenScale", Err.Number, Err.Description
Resume GetScreenScaleExit
End Select
End Sub

Private Function GetTwips(intXResolution As Integer, intAxis As Integer)

'' Experience has shown that the twips/pixel ratios
'' are dependent on the screen resolution. If you find this
'' not to be true in your particular case, you''ll need to modify
'' this routine.

Select Case intXResolution
Case 1024, 1280
GetTwips = IIf(intAxis = glrcXAxis, _
glrcDesignXTwipsHiRes, glrcDesignYTwipsHiRes)
Case 640, 800
GetTwips = IIf(intAxis = glrcXAxis, _
glrcDesignXTwipsLoRes, glrcDesignYTwipsLoRes)
Case Else
'' If the value is invalid, just assume the designed used
'' a high-res screen. The worst this can do is cause
'' an image that''s a little small.
GetTwips = IIf(intAxis = glrcXAxis, _
glrcDesignXTwipsHiRes, glrcDesignYTwipsHiRes)
End Select
End Function

Function glrResizeForm(frm As Form, ByVal fDoResize As Variant, rctOriginal
As glrTypeRect)

'' Called from the Resize event of forms.
'' Attempt to resize the form and all its
'' controls. Don''t do anything if the
'' current height of the form is 0, or if it''s iconic.

'' From Microsoft Access 95 Developer''s Handbook
'' by Litwin, Getz, Gilbert, and Reddick (Sybex)
'' Copyright 1995. All rights reserved.

'' In:
'' frm: A reference to the form in question
'' fDoResize: Yes/No (Actually do the resize, or just track the
information?)
'' rctOriginal: the original coordinates
'' Out:
'' Nothing

Dim rctNew As glrTypeRect
Dim rctClient As glrTypeRect
Dim varTemp As Variant
Dim intWidth As Integer
Dim intHeight As Integer
Dim sglFactorX As Single
Dim sglFactorY As Single
On Error GoTo glrResizeWindowError
'' Make sure the user hasn''t sized this thing down
'' to the nubs. If the client area is 0 height,
'' it''s time to call it quits.
glr_apiGetClientRect frm.hwnd, rctNew
intHeight = (rctNew.Y2 - rctNew.Y1)
If intHeight = 0 Or glr_apiIsIconic(frm.hwnd) Then
Exit Function
End If

'' Get the current width. Already found the
'' current height.
intWidth = (rctNew.X2 - rctNew.X1)

'' Calc the scaling factor, given the current
'' height/width and the previous height/width.
'' Could be that rctOriginal has not yet been
'' initialized, so trap for that error.

sglFactorX = intWidth / (rctOriginal.X2 - rctOriginal.X1)
sglFactorY = intHeight / (rctOriginal.Y2 - rctOriginal.Y1)

sglFactorOK:
'' Store away the current values for
'' the next time through here.
With rctOriginal
.X1 = rctNew.X1
.X2 = rctNew.X2
.Y1 = rctNew.Y1
.Y2 = rctNew.Y2
End With
'' If the ratios are 1, there''s nothing to do.
If (sglFactorX <> 1) Or (sglFactorY <> 1) Then
'' If you actually want to do some resizing, do it now.
If fDoResize Then
SetFormSize frm, sglFactorX, sglFactorY, rctNew, False
End If
End If

glrResizeWindowExit:
Exit Function

glrResizeWindowError:
If Err = glrcErrDivisionByZero Then
sglFactorX = 1
sglFactorY = 1
Resume sglFactorOK
Else
HandleError "glrResizeForm", Err.Number, Err.Description
Resume Next
End If
End Function

Function glrScaleForm(frm As Form, intX As Integer, intY As Integer,
rctOriginal As glrTypeRect)

'' Called from the Open event of forms.
'' Attempts to scale the form appropriately
'' for the given screen size, as compared
'' to the size screen on which it was designed.

'' From Microsoft Access 95 Developer''s Handbook
'' by Litwin, Getz, Gilbert, and Reddick (Sybex)
'' Copyright 1995. All rights reserved.
''
'' In:
'' frm: A reference to the form in question
'' intX: the horizontal screen resolution at which the form was
designed.
'' intY: the vertical screen resolution at which the form was
designed.
'' rctOriginal: original coordinates
''
'' Out:
'' Nothing
'' Comments:
'' Use a function call like this:
'' intRetval = glrScaleForm(Me, 640, 480, rctOriginal)
'' to autoscale a form created at 640x480 resolution.

Dim intTwipsPerPixelX As Integer
Dim intTwipsPerPixelY As Integer
Dim intScreenX As Integer
Dim intScreenY As Integer

Dim sglFactorX As Single
Dim sglFactorY As Single

GetScreenScale intX, intY, sglFactorX, sglFactorY

'' Whether or not this form gets rescaled,
'' you''ll need to store away the current size
'' for later. The reason you must call GetFormSize
'' here, rather than glr_apiGetClientRect, is that
'' you need the screen positioning information
'' which you don''t get with GetClientRect.
GetFormSize frm, rctOriginal

'' If the x and y factors are both 1, there''s nothing
'' to do, so get out here.
If (sglFactorX = 1) And (sglFactorY = 1) Then Exit Function

'' If you don''t want forms to expand (they were created on a
'' lower-resolution device than the current device), but only
'' shrink (they were created on a higher-resolution device
'' than the current device), then uncomment the next line.
''If (sglFactorX > 1) And (sglFactorY > 1) Then Exit Sub
DoCmd.RepaintObject
SetFormSize frm, sglFactorX, sglFactorY, rctOriginal, True
End Function
Private Sub HandleError(strFunction As String, intErr As Integer, strError
As String)
MsgBox "Error: " & strError & " (" & intErr & ")", vbExclamation,
strFunction
End Sub

Private Sub SetFormSize(frm As Form, sglFactorX As Single, sglFactorY As
Single, rct As glrTypeRect, fMove As Integer)

'' Actually do the work to resize all the controls
'' on the given form, and then resize the form
'' itself.

Dim intTemp As Integer
Dim intWidth As Integer
Dim intHeight As Integer
Dim Ctl As Control
Dim sglFontSize As Single
Dim intI As Integer
Dim intGroups As Integer
Dim aGroups() As glrTypeDimensions
Dim colGroups As New Collection
Dim varTemp As Variant

On Error GoTo SetFormSizeError

DoCmd.Hourglass True
frm.Painting = False

'' If the form is growing vertically, then need to
'' fix up the section heights now. If it''s shrinking,
'' fix up the heights AFTER you place the controls.
'' The same goes for the form width.
If sglFactorY > 1 Then
'' Fix up all the section heights.
FixSections frm, sglFactorY
varTemp = frm.Width * sglFactorX
If varTemp > glrcMaxTwips Then
frm.Width = glrcMaxTwips
Else
frm.Width = varTemp
End If
End If

'' Now deal with all the controls
'' Go through and deal with all the groups and subforms first.
intGroups = FixGroups(frm, aGroups(), sglFactorX, sglFactorY)

'' Now go back and deal with all the rest of the controls.
For Each Ctl In frm.Controls

Select Case Ctl.ControlType
Case acOptionGroup
GoTo NextCtl

Case acSubform
'' If you''ve got a subform, then recurse on down into this
'' routine again, dealing with all the controls inside of
'' that subform.
SetFormSize Ctl.Form, sglFactorX, sglFactorY, rct, False

GoTo NextCtl
Case acPage
''an acPage, is a ''tab page'' on a tab control
''The ''tab page'' is automatically resized by the tab control
when the tab control itself is resized
''so.. don''t resize the tab page. If the tab page WERE TO BE
resized, the tab control will automatically
''resize itself to match the page size (i.e. tab control
resizes increasing the page size, then page is resized
''increasing the tabcontrol size, then the next page is
resized, which again resizes everything etc, etc etc....
''the tab control would grow X times for each page on it)
GoTo NextCtl
End Select

'' So the control isn''t a subform and it''s not a group.
'' Therefore, just scale it to the correct size.

'' First, fix up the font, if this control has a font
'' that needs to be fixed up.
If ChangeFont(Ctl) Then
sglFontSize = Ctl.FontSize * sglFactorY
Else
sglFontSize = -1
End If

'' Set the top, left and width values.

If frm.CurrentView <> acDatasheetView Then
Ctl.Top = Ctl.Top * sglFactorY
Ctl.Left = Ctl.Left * sglFactorX
Ctl.Width = Ctl.Width * sglFactorX
End If

'' Change the height, if that''s required.
If ChangeHeight(Ctl) Then
Ctl.Height = Ctl.Height * sglFactorY
End If

'' Only attempt to change the font size for
'' certain types of controls.
If sglFontSize >= 1 And sglFontSize <= 127 Then
Ctl.FontSize = sglFontSize
End If
NextCtl:
Next Ctl

'' If the form is shrinking vertically, fix up the
'' section heights now that all the controls have been
'' placed. The same goes for the form width.
If sglFactorY < 1 Then
'' Fix up all the section heights.
FixSections frm, sglFactorY
frm.Width = frm.Width * sglFactorX
End If

'' Go through and fix up the option groups/subforms,
'' which may have been distorted by changes to
'' the internal controls.
For intI = 1 To intGroups
With frm(aGroups(intI).strCtlName)
.Top = aGroups(intI).sglTop
.Left = aGroups(intI).sglLeft
.Width = aGroups(intI).sglWidth
.Height = aGroups(intI).sglHeight
End With
Next intI

If fMove Then
intWidth = Int((rct.X2 - rct.X1) * sglFactorX)
intHeight = Int((rct.Y2 - rct.Y1) * sglFactorY)

rct.X1 = Int(rct.X1 * sglFactorX)
rct.Y1 = Int(rct.Y1 * sglFactorY)
rct.X2 = rct.X1 + intWidth
rct.Y2 = rct.Y1 + intHeight

intTemp = glr_apiMoveWindow(frm.hwnd, rct.X1, rct.Y1, intWidth,
intHeight, True)

'' Use the Window-Size To Fit menu item.
DoCmd.DoMenuItem acFormBar, acWindow, acSizeToFit, , acMenuVer70

End If

SetFormSizeExit:
frm.Painting = True
DoCmd.Hourglass False
Exit Sub

SetFormSizeError:
Select Case Err
Case glrcErrInvalidProperty
Resume Next
Case Else
''HandleError "SetFormSize", Err.Number, Error.Description
Resume Next
End Select
End Sub

任何好的Form Resizing代码？ [英] Any good Form Resizing code?

问题描述

推荐答案

相关文章

数据库最新文章

热门教程

热门工具

登录关闭

任何好的Form Resizing代码？ [英] Any good Form Resizing code?

问题描述

推荐答案

相关文章

数据库最新文章

热门教程

热门工具

登录 关闭

登录关闭