vb6 更改屏幕分辨率 并立即生效

Question

请问在vb6下如何更改系统的分辨率，因为我做的东西在800 * 600 下显示效果是最好的，过大或过小，都会使界面变的不完整，我想在程序一打开的时候首先检查分辨率，如果不是指定的800 * 600，就更改为800 * 600 ,程序退出时再改回去。谁有源码?

Answer 1

http://community.csdn.net/Expert/topic/4418/4418372.xml?temp=.3319208

Answer 2

http://community.csdn.net/Expert/topic/4271/4271437.xml?temp=.966427

Answer 3

Option Explicit 
Public oldwidth As Integer, oldheight As Integer, oldcolor As Integer, oldfreq As Long 
Private Declare Function ChangeDisplaySettings Lib "user32.dll" Alias "ChangeDisplaySettingsA" (ByRef lpDevMode As DEVMODE, ByVal dwFlags As Long) As Long 
Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, ByRef lpDevMode As DEVMODE) As Long 
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long 
Private Const ENUM_CURRENT_SETTINGS = 1 
Private Const BITSPIXEL = 12 Const DM_PELSHEIGHT As Long = &H100000 
Const DM_PELSWIDTH As Long = &H80000 
Const DM_BITSPERPEL As Long = &H40000 
Const DM_DISPLAYFREQUENCY As Long = &H400000 Const CCHDEVICENAME As Long = 32 
Const CCHFORMNAME As Long = 32 
Const CDS_TEST = &H4 
Const GDC_FREQ = 116 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 Sub Form_Activate() 
   oldwidth = GetDisplayWidth 
   oldheight = GetDisplayHeight 
   getcolor 
   getfreq 
   Call initscreen 
End Sub 
Private Sub Form_KeyPress(KeyAscii As Integer) 
   If KeyAscii = 27 Then 
      Unload Me 
   End If 
End Sub 
Private Sub Form_Unload(Cancel As Integer) 
   restscreen 
End Sub 
Public Sub initscreen() 
    Dim nwidth As Long, nheight As Long, ncolor As Integer, nfreq As Long 
    nwidth = 800: nheight = 600: ncolor = 16: nfreq = 60 
    Call SetDisplaymode(nwidth, nheight, ncolor, nfreq) 
End Sub 
Public Sub restscreen() 
   Dim nwidth As Long, nheight As Long, ncolor As Integer, nfreq As Long 
   nwidth = oldwidth: nheight = oldheight: ncolor = oldcolor: nfreq = oldfreq 
   Call SetDisplaymode(nwidth, nheight, ncolor, nfreq) 
End Sub 
Public Function SetDisplaymode(LngWidth As Long, LngHeight As Long, IntColor As Integer, LngFrequency As Long) As Long 
   Dim newDevmode As DEVMODE 
   Dim lngP As Long 
   EnumDisplaySettings 0&, 0&, newDevmode 
   With newDevmode 
      .dmFields = DM_PELSHEIGHT Or DM_PELSWIDTH Or DM_BITSPERPEL Or DM_DISPLAYFREQUENCY 
      .dmPelsWidth = LngWidth 
      .dmPelsHeight = LngHeight 
      .dmBitsPerPel = IntColor 
      .dmDisplayFrequency = LngFrequency 
   End With 
   SetDisplaymode = ChangeDisplaySettings(newDevmode, CDS_TEST) 
End Function 
Public Function GetDisplayWidth() As Integer 
   On Error Resume Next 
   GetDisplayWidth = Screen.Width \ Screen.TwipsPerPixelX 
End Function 
Public Function GetDisplayHeight() As Integer 
   On Error Resume Next 
   GetDisplayHeight = Screen.Height \ Screen.TwipsPerPixelY 
End Function 
Public Function getfreq() As Integer 
   On Error Resume Next 
   oldfreq = GetDeviceCaps(Me.hdc, GDC_FREQ) 
End Function 
Public Sub getcolor() 
   On Error Resume Next 
   oldcolor = Format$(GetDeviceCaps(hdc, BITSPIXEL)) 
End Sub