VB自动调整分辨率问题？

[longsirs]

怎样使程序去适应不同的分辨率或不同分辨率的机器去适应你的程序？

[longsirs]

你好！很高兴认识你们，感谢两位的帮助！
jiemupig(伦涯飘)，你的程序比较简单，但能把怎么应用写得更详细些吗？

wangdeshui(阿水)，如果加两个command来控制，按comand1变为640x480,按command2恢复原状1024x768
能写个事例吗？定义和函数部分代码是不是要写到模块里面去？

[xjoil]

试试这个吧!
Option Explicit
Dim OldWidth, OldHeight As Integer

Private Sub RestoreDisplayMode() '恢复分辩率
Call SetDisplayMode(nOrgWidth, nOrgHeight, 0)
End Sub

Private Function GetDisplayWidth() As Integer '获得当前屏幕分辩率的宽度
GetDisplayWidth = Screen.Width \ Screen.TwipsPerPixelX
End Function

Private Function GetDisplayHeight() As Integer '获得当前屏幕分辩率的高度
GetDisplayHeight = Screen.Height \ Screen.TwipsPerPixelY
End Function

'设置显示器分辨率的执行函数
Private Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) As Long ', Freq As Long) As Long
On Error GoTo ErrorHandler
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
Const DM_DISPLAYFLAGS = &H200000
Const DM_DISPLAYFREQUENCY = &H400000
With pNewMode
.dmSize = Len(pNewMode)
If Color = 0 Then 'Color = 0 时不更改屏幕颜色
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_DISPLAYFREQUENCY'属性率的更改还是没办法,不过,不加入此DM_DISPLAYFREQUENCY这个参数,只要系统支持,应该不会更改刷新率的
End If
.dmPelsWidth = Width
.dmPelsHeight = Height
If Color <> 0 Then
.dmBitsPerPel = Color
End If
End With
pOldMode = lStrCpy(pNewMode, pNewMode)
SetDisplayMode = ChangeDisplaySettings(pOldMode, 1)
Exit Function
ErrorHandler:
MsgBox Err.Description, vbCritical, ""
End Function

Private Sub Form_Load()
OldWidth = GetDisplayWidth '当前分辩率的宽度
OldHeight = GetDisplayHeight '当前分辩率的高度

If OldWidth <> 800 Or OldHeight <> 600 Then
Call SetDisplayMode(800, 600, 16)
End If
End Sub

[winehero]

UP,等会过来

[longsirs]

谢谢各位！
xjoil(黄豆) 你好，调试不能通过，变量未定义！

[「已注销」]

在这个过程中写事件。

Private Sub Form_Resize()
On Error Resume Next
If Me.Height < 7600 Then Me.Height = 7600
If Me.Width < 11600 Then Me.Width = 11600
Me.tvw.Height = Me.ScaleHeight - Me.Toolbar1.Height
End Sub

[wangdeshui]

我们经常看到许多 Win95 的应用程序（尤其是游戏）在运行它的时候改变屏幕的设置，运行完后恢复，在 VB 中，我们可以用以下方法实现：

文中的下划线(_)为接上一行。
　
定义

'Vb man 2001
'URL: http://goodvbman.yeah.net
'E-mail: [e-mail]

Private Declare Function lstrcpy _
Lib "kernel32" Alias "lstrcpyA" _
(lpString1 As Any, lpString2 As Any) _
As Long
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function _
ChangeDisplaySettings Lib _
"User32" Alias "ChangeDisplaySettingsA" (_
ByVal lpDevMode As Long, _
ByVal dwflags As Long) As Long


函数

'Vb man 2001
'URL: http://goodvbman.yeah.net
'E-mail: [e-mail]

Public Function SetDisplayMode(Width As _
Integer,Height As Integer, Color As _
Integer) As Long
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
Dim NewDevMode As DEVMODE
Dim pDevmode As Long
With NewDevMode
.dmSize = 122
If Color = -1 Then
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_PELSWIDTH Or _
DM_PELSHEIGHT Or DM_BITSPERPEL
End If
.dmPelsWidth = Width
.dmPelsHeight = Height
　
If Color <> -1 Then
.dmBitsPerPel = Color
End If
End With
pDevmode = lstrcpy(NewDevMode, NewDevMode)
SetDisplayMode = ChangeDisplaySettings(pDevmode, 0)
End Function


例子调用：改变为 640x480x24位：

i = SetDisplayMode(640, 480, 24)

[wangdeshui]

'改变屏幕分辨率
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const ENUM_CURRENT_SETTINGS = 1
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwflags As Long) As Long
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Dim pNewMode As DEVMODE
Dim pOldMode As Long
Dim nOrgWidth As Integer, nOrgHeight As Integer

'设置显示器分辨率的执行函数
Private Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) As Long ', Freq As Long) As Long
On Error GoTo ErrorHandler
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
Const DM_DISPLAYFLAGS = &H200000
Const DM_DISPLAYFREQUENCY = &H400000
With pNewMode
.dmSize = Len(pNewMode)
If Color = 0 Then 'Color = 0 时不更改屏幕颜色
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_DISPLAYFREQUENCY'属性率的更改还是没办法,不过,不加入此DM_DISPLAYFREQUENCY这个参数,只要系统支持,应该不会更改刷新率的
End If
.dmPelsWidth = Width
.dmPelsHeight = Height
If Color <> 0 Then
.dmBitsPerPel = Color
End If
End With
pOldMode = lstrcpy(pNewMode, pNewMode)
SetDisplayMode = ChangeDisplaySettings(pOldMode, 1)
Exit Function
ErrorHandler:
MsgBox Err.Description, vbCritical, "VB广场"
End Function

Private Sub Command1_Click()
Dim nWidth As Integer, nHeight As Integer, nColor As Integer
Select Case Combo1.ListIndex
Case 0
nWidth = 640: nHeight = 480: nColor = 16 '640*480*16位真彩色,256色nColor = 8,16色nColor = 4,nColor = 0 表示不改变颜色
Case 1
nWidth = 640: nHeight = 480: nColor = 24
Case 2
nWidth = 640: nHeight = 480: nColor = 32
Case 3
nWidth = 800: nHeight = 600: nColor = 16
Case 4
nWidth = 800: nHeight = 600: nColor = 24
Case 5
nWidth = 800: nHeight = 600: nColor = 32
Case 6
nWidth = 1024: nHeight = 768: nColor = 16
Case 7
nWidth = 1024: nHeight = 768: nColor = 24
Case 8
nWidth = 1024: nHeight = 768: nColor = 32
Case other
nWidth = 800: nHeight = 600: nColor = 16
End Select
Call SetDisplayMode(nWidth, nHeight, nColor) '注意,系统不支持的显示模式不能选,否则,准备用安全模式重启动吧.API函数EnumDisplaySettings可以选择系统支持的模式,自己去写吧,也很简单.如果你还有什么问题,请给我发信或留言.
End Sub
'窗体加一个Combobox,一个Commandbutton控件
Private Sub Form_Load()
Combo1.AddItem "640*480*16位真彩色"
Combo1.AddItem "640*480*24位真彩色"
Combo1.AddItem "640*480*32位真彩色"
Combo1.AddItem "800*600*16位真彩色"
Combo1.AddItem "800*600*24位真彩色"
Combo1.AddItem "800*600*32位真彩色"
Combo1.AddItem "1024*768*16位真彩色"
Combo1.AddItem "1024*768*24位真彩色"
Combo1.AddItem "1024*768*32位真彩色"
Combo1.Text = Combo1.List(0)
nOrgWidth = GetDisplayWidth
nOrgHeight = GetDisplayHeight
'nOrgWidth = GetSystemMetrics(SM_CXSCREEN)'两种获取初始屏幕大小的方法均可
'nOrgHeight = GetSystemMetrics(SM_CYSCREEN)
End Sub

Private Function GetDisplayWidth() As Integer
GetDisplayWidth = Screen.Width \ Screen.TwipsPerPixelX
End Function

Private Function GetDisplayHeight() As Integer
GetDisplayHeight = Screen.Height \ Screen.TwipsPerPixelY
End Function

Private Sub RestoreDisplayMode()
Call SetDisplayMode(nOrgWidth, nOrgHeight, 0)
End Sub

Private Sub Form_Unload(Cancel As Integer)
RestoreDisplayMode
End Sub

[longsirs]

谢谢wangdeshui(阿水)，问题终于解决了，结贴，阿水接分。也非常感谢楼上各位兄弟地参与。

[longsirs]

楼上的兄弟，再帮一把，谢谢了！