'****************************************
'功能：让图片适应屏幕大小
'名称：AdaptScrn()
'参数：Px,Py 图像宽高
'返回：Px,Py 注意是地址传递
'****************************************
Public Sub AdaptScrn(ByRef Px, ByRef Py)
Dim x, y As Integer '图像宽高
Dim w, h As Integer '屏幕宽高
Dim x0, y0 As Single '适应后的值
x = Px: y = Py '保护原值
w = Screen.Width / Screen.TwipsPerPixelX
h = Screen.Height / Screen.TwipsPerPixelY
'适应屏幕核心算法
If x > y Then '宽大于高
x0 = w: y0 = y * (w / x)
'高度不正确，再次修正
If y0 > h Then y0 = h: x0 = x * (h / y)
ElseIf x < y Then '宽小于高
y0 = h: x0 = x * (h / y)
'宽度不正确，再次修正
If x0 > w Then x0 = w: y0 = y * (w / x)
Else '宽高相等
x0 = h: y0 = h
End If
Px = x0: Py = y0
End Sub
