求教！！！！！！！！！！！！

luqigaoyan

在800*600下写的窗口，是表格样式的，正好满屏，但是在1024*768下却很小，很难看！请问如何实现也是满屏呀？？？？？（有点象flash矢量图一样的，可以吗？？）

ququ

让控件自适应屏幕分辨率2
来源：ACCESS爱好者
'这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！强列推荐
''如果你是在1024*768的分辨率下写的程序，就把下面那句改为
Const DesignSize = 1024，如果是800*600分
'辨率下写的，就改为Const DesignSize = 800
'用法：把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事
'件里加入Call FormResiz_OnOpen(Me)
'
'Const DesignSize = 1024
Const DesignSize = 800
'☆★☆★☆★☆★☆★☆★☆★☆★☆★
'API宣言
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As RECT) As Long
'Type宣言
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
'国标码宣言
Dim frm As Form
Dim ctrl As Control
Dim prp As Property
Dim rat As Double
Dim flgSec
Dim X As Long
Dim WinHeight As Long
Dim hWnd As Long
Dim ret As Long
Dim i As Integer
Dim R As RECT
Dim SizeL As Long
Dim SizeT As Long
Dim SizeW As Long
Dim SizeH As Long
'--------------------------------------------------------------------------------
Public Function FormResiz_OnOpen(parFrm As Form, Optional perSizeL As Long, Optional perSizeT As Long, Optional perSizeW As Long, Optional perSizeH As Long)
On Error Resume Next
Set frm = parFrm
'窗口驾驶盘的取得
hWnd = GetDesktopWindow()
'现在分辨率取得
ret = GetWindowRect(hWnd, R)
'比例计算 常例：现在800 开发1024 800/1024 = 0.78加倍
X = (R.x2 - R.x1)
rat = X / DesignSize
SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0
If Not IsEmpty(perSizeL) = True Then
SizeL = perSizeL * rat
SizeT = perSizeT * rat
SizeW = perSizeW * rat
SizeH = perSizeH * rat
End If
'现在分辨率＝开发分辨率如果终了
If X = DesignSize Then Exit Function
If X < DesignSize Then
'细小策划时、控制＞部分＞表单的次序
Call ChangeCtrl
Call ChengeSec
Call ChangeFrm
Else
'大掬取时、表单＞部分＞控制的次序
Call ChangeFrm
Call ChengeSec
Call ChangeCtrl
End If
'最后、表单的使清新
frm.Refresh
Exit Function
End Function
'--------------------------------------------------------------------------------
Private Sub ChangeCtrl()
On Error Resume Next
'控制转
For Each ctrl In frm.Controls
'*******************************************************************
'选项卡修正，原著没有这段代码，后来有个朋友发现了这个BUG，就是选项卡的位置会偏得很厉害
'所以就加了这段代码来修正
'主要是"Top", "Height","Left","Width"这几个参数的值，根据实际情况适当调整就行了
If ctrl.ControlType = 123 Or ctrl.ControlType = 124 Then
For Each prp In ctrl.Properties
Select Case prp.Name
Case "FontSize", "DatasheetFontHeight"
prp.value = Fix(prp.value * rat + 0.5)
Case "FontWeight"
prp.value = Fix((prp.value * rat) / 100) * 100
Case "Top", "Height"
prp.value = Fix(prp.value * rat * 0.85)
'prp.value = Fix(prp.value * rat)
Case "Left"
prp.value = Fix(prp.value * rat * 0.9)
Case "Width"
prp.value = Fix(prp.value * rat * 0.7)
End Select
Next prp
'********************************************************************************************
Else
'属性转
For Each prp In ctrl.Properties
'大小·配置关于属性被发现们压缩
Select Case prp.Name
Case "FontSize", "DatasheetFontHeight"
'通常计算假如行…情况之下的 +0.5 之类的话不需要是…但…、
'捆Zo~Ma办法。稍微心情坏因为 +0.5
prp.value = Fix(prp.value * rat + 0.5)
Case "FontWeight"
prp.value = Fix((prp.value * rat) / 100) * 100
Case "Left", "Top", "Width", "Height"
prp.value = Fix(prp.value * rat)
End Select
Next prp
End If
Next ctrl
End Sub
'--------------------------------------------------------------------------------
Private Sub ChengeSec()
On Error GoTo Err_Disp
'部分转
flgSec = True
i = 0
'不存在部分的参照错误化验出终了
Do Until flgSec = False
'部分被发现们高度变更
frm.Section(i).Height = Fix(frm.Section(i).Height * rat)
i = i + 1
Loop
Exit Sub
Err_Disp:
If Err = 2462 Then
flgSec = False
Resume Next
Else
MsgBox Err.Description
End If
Resume Next
End Sub
'--------------------------------------------------------------------------------
Private Sub ChangeFrm()
On Error Resume Next
'表单的大小变更
'Optional参数数值渡

duzili

有一个vb模块，我在vb6下通过，access下没有试过（但编译通过）。
'=======================================
把以下代码粘贴在一个模块中
'=======================================
Option Compare Database

'这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方
'案！强列推荐

'☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆
'如果你是在1024*768的分辨率下写的程序，就把下面那句改为
'Const DesignSize = 1024，如果是800*600分
'辨率下写的，就改为Const DesignSize = 800
'用法：把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事
'件里加入Call FormResiz_OnOpen(Me)
'☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆☆

'Const DesignSize = 1024
Const DesignSize = 800

'☆★☆★☆★☆★☆★☆★☆★☆★☆★

'API宣言
Declare Function GetDesktopWindow Lib "User32" () As Long

Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As RECT) As Long


'Type宣言
Type RECT

x1 As Long

y1 As Long

x2 As Long

y2 As Long

End Type


'国标码宣言
Dim frm As Form

Dim ctrl As Control

Dim prp As Property

Dim rat As Double

Dim flgSec

Dim X As Long

Dim WinHeight As Long

Dim hWnd As Long

Dim ret As Long

Dim i As Integer

Dim R As RECT

Dim SizeL As Long

Dim SizeT As Long

Dim SizeW As Long

Dim SizeH As Long


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

Public Function FormResiz_OnOpen(parFrm As Form, Optional perSizeL As Long, Optional perSizeT As Long, Optional perSizeW As Long, Optional perSizeH As Long)


On Error Resume Next


Set frm = parFrm


'窗口驾驶盘的取得
hWnd = GetDesktopWindow()

'现在分辨率取得
ret = GetWindowRect(hWnd, R)

'比例计算 常例：现在800 开发1024 800/1024 = 0.78加倍
X = (R.x2 - R.x1)

rat = X / DesignSize


SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0

If Not IsEmpty(perSizeL) = True Then

SizeL = perSizeL * rat

SizeT = perSizeT * rat

SizeW = perSizeW * rat

SizeH = perSizeH * rat

End If


'现在分辨率＝开发分辨率如果终了
If X = DesignSize Then Exit Function


If X < DesignSize Then

'细小策划时、控制＞部分＞表单的次序
Call ChangeCtrl

Call ChengeSec

Call ChangeFrm

Else

'大掬取时、表单＞部分＞控制的次序
Call ChangeFrm

Call ChengeSec

Call ChangeCtrl

End If


'最后、表单的使清新
frm.Refresh

Exit Function


End Function


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

Private Sub ChangeCtrl()

On Error Resume Next


'控制转
For Each ctrl In frm.Controls
'*******************************************************************************************
'选项卡修正，原著没有这段代码，后来有个朋友发现了这个BUG，就是选项卡的位置会偏得很厉害
'所以就加了这段代码来修正
'主要是"Top", "Height","Left","Width"这几个参数的值，根据实际情况适当调整就行了
If ctrl.ControlType = 123 Or ctrl.ControlType = 124 Then
For Each prp In ctrl.Properties
Select Case prp.Name
Case "FontSize", "DatasheetFontHeight"
prp.Value = Fix(prp.Value * rat + 0.5)
Case "FontWeight"
prp.Value = Fix((prp.Value * rat) / 100) * 100
Case "Top", "Height"
prp.Value = Fix(prp.Value * rat * 0.85)
'prp.Value = Fix(prp.Value * rat)
Case "Left"
prp.Value = Fix(prp.Value * rat * 0.9)
Case "Width"
prp.Value = Fix(prp.Value * rat * 0.7)
End Select
Next prp
'********************************************************************************************
Else
'属性转
For Each prp In ctrl.Properties
'大小·配置关于属性被发现们压缩
Select Case prp.Name
Case "FontSize", "DatasheetFontHeight"
'通常计算假如行…情况之下的 +0.5 之类的话不需要是…但…、
'捆Zo~Ma办法。稍微心情坏因为 +0.5
prp.Value = Fix(prp.Value * rat + 0.5)
Case "FontWeight"
prp.Value = Fix((prp.Value * rat) / 100) * 100
Case "Left", "Top", "Width", "Height"
prp.Value = Fix(prp.Value * rat)
End Select
Next prp
End If
Next ctrl


End Sub


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

Privat

宿命的风

至尽没看过这样的例子。