resolu.bas

金水区行政审批服务软件窗口系统

Attribute VB_Name = "Resolu"
'***************************说明***********************************
'*特别提示：本代码将实现根据不同的屏幕分辨率调整窗体中            *
'*          各部件的大小和位置，以适应不同的屏幕分辨率            *
'*          的需要，支持屏幕分辨率有：800*600 1024*768            *
'******************************************************************
'Resolution Resize and Run Time Control Resize.
'Module for automatically resizing forms and
'controls with varying screen resolutions. This is
'an adaptation of a Microsoft Knowledge Base
'article. The example worked as it was but half the
'code was on the form. I wanted a complete module
'to add to any app easily. To use it simply add
' "Call AdjustForm(Me)" to the Form_Load event
'and "Call FormResize(Me)" to the Form_Resize
'event.  Also change the design time resolution
'values. It is coded to 640x480 since my video
'adapter will not support higher at 16 bit color.
'The Microsoft article said it was for VB5/6

Option Explicit

Public Xtwips As Integer, Ytwips As Integer
Public Xpixels As Integer, Ypixels As Integer

Type FRMSIZE
   Height As Long
   Width As Long
End Type

Public RePosForm As Boolean
Public DoResize As Boolean
Dim MyForm As FRMSIZE
Dim DesignX As Integer
Dim DesignY As Integer
Dim ScaleFactorX As Single, ScaleFactorY As Single
Sub Resize_For_Resolution(ByVal SFX As Single, ByVal SFY As Single, MyForm As Form)
Dim i As Integer
Dim SFFont As Single
SFFont = (SFX + SFY) / 2
On Error Resume Next
With MyForm
  For i = 0 To .Count - 1
   If TypeOf .Controls(i) Is ComboBox Then
     .Controls(i).left = .Controls(i).left * SFX
     .Controls(i).top = .Controls(i).top * SFY
     .Controls(i).Width = .Controls(i).Width * SFX
   Else
     .Controls(i).Move .Controls(i).left * SFX, _
      .Controls(i).top * SFY, _
      .Controls(i).Width * SFX, _
      .Controls(i).Height * SFY
   End If
     .Controls(i).FontSize = .Controls(i).FontSize * SFFont
  Next i
  If RePosForm Then
     .Move .left * SFX, .top * SFY, .Width * SFX, .Height * SFY
  End If
End With
End Sub
Public Sub FormResize(TheForm As Form)
Dim ScaleFactorX As Single, ScaleFactorY As Single
If Not DoResize Then
   DoResize = True
   Exit Sub
End If
RePosForm = False
ScaleFactorX = TheForm.Width / MyForm.Width
ScaleFactorY = TheForm.Height / MyForm.Height
Resize_For_Resolution ScaleFactorX, ScaleFactorY, TheForm
MyForm.Height = TheForm.Height
MyForm.Width = TheForm.Width
End Sub
Public Sub AdjustForm(TheForm As Form)
Dim res As String
'-----------------------------------------------------------
' Returns resolution of system
' Put the design time resolution in here
'-----------------------------------------------------------
DesignX = 800
DesignY = 600
RePosForm = True
DoResize = False
Xtwips = Screen.TwipsPerPixelX
Ytwips = Screen.TwipsPerPixelY
Ypixels = Screen.Height / Ytwips
Xpixels = Screen.Width / Xtwips
ScaleFactorX = (Xpixels / DesignX)
ScaleFactorY = (Ypixels / DesignY)
TheForm.ScaleMode = 1
Resize_For_Resolution ScaleFactorX, ScaleFactorY, TheForm
res = Str$(Xpixels) + "  by " + Str$(Ypixels)
'Debug.Print Res
MyForm.Height = TheForm.Height
MyForm.Width = TheForm.Width
End Sub
Public Sub GetScreenFBL(Ypixel As Integer)
'此过程的作用是取得当前显示器屏幕分辨率
'2003-10-28 dww pm16:49
'----------------------------------------------------------
'进行分辨率的计算
DesignX = 800
DesignY = 600
Xtwips = Screen.TwipsPerPixelX
Ytwips = Screen.TwipsPerPixelY
Ypixels = Screen.Height / Ytwips
Xpixels = Screen.Width / Xtwips
'----------------------------------------------------------
'将算出的分辨率Y值返回返回数值可能是600，768分别代表
'800*600和1024*768的分辨率 2003-10-28 dww pm18:28
Ypixel = Ypixels
'----------------------------------------------------------
'测试数据屏幕分辨率输出
'Dim res As String
'res = Str$(Xpixels) + "  by " + Str$(Ypixels)
'Debug.Print res
End Sub