INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Visual Basic (Microsoft) Versions 5/6 FAQ

Windows API

Run an application in a different video mode... by msc0tt
Posted: 17 Dec 02

'
' File: SetVideoMode.VB6
' Date: December 2002
' Name: M. Scott (mscott@axys.com)
'
' Purpose: This program is a wrapper intended for launching an application
'          in a specific screen resolution.  Also possible is changing
'          the colour depth and monitor refresh rate.  When the application
'          ends, the video mode is returned to original settings.
'
' Syntax: SetVideoMode <WIDTH> <HEIGHT> <COLOURS> <FREQ> <PROG> [ARGS]
'
' WIDTH   : in Pixels (i.e. 640)
' HEIGHT  : in Pixels (i.e. 480)
' COLOURS : bits of colour depth (4,8,16,24,32 or 0=don't change)
' FREQ    : monitor refresh rate (0=don't change)
' PROG    : executable to run
' ARGS    : optional arguments to executable
'
' Bugs: Probably.  This is a one-off util for a specific machine (W2K).
'       No testing of other situations was done.
'
' Credits: Too many to list (besides I don't remember them all).  The one
'          worth listing is Tek-Tips.  I love these forums!
'
' Disclaimers: I'm a pilot, not a programmer.  This isn't the prettiest
'              or most efficient code you will ever see.  It is the
'              result of several snippits of code, accumulated from
'              different sources.  Once completed, I attempted to
'              apply my own "style" to the source.
'
' History: My two year old daughter loves "Reader Rabbit Toddler" which
'          I have installed on my home computer.  She is able to double-
'          click the desktop icon to start the program, but it will NOT
'          run if the video resolution is anything BUT 640x480.  She is
'          not yet able to change the Res on her own.  If I'm not quick
'          with resetting the Res for her, tears can ensue....
'
'          BTW: Just a quick plug for Virtual-CD!  This is a FANTASTIC
'          utility and works with all her games so far...
'

Option Explicit

Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_DISPLAYFREQUENCY = &H400000
Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H4
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const BITSPIXEL = 12
Const VREFRESH = 116

Const HWND_BROADCAST = &HFFFF
Const WM_DISPLAYCHANGE = &H7E
Const SPI_SETNONCLIENTMETRICS = 42

Const NORMAL_PRIORITY_CLASS = &H20&
Const INFINITE = -1&

Private Type DEVMODE
   dmDeviceName As String * CCDEVICENAME
   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 * CCFORMNAME
   dmUnusedPadding As Integer
   dmBitsPerPel As Integer
   dmPelsWidth As Long
   dmPelsHeight As Long
   dmDisplayFlags As Long
   dmDisplayFrequency As Long
   End Type

Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   dwX As Long
   dwY As Long
   dwXSize As Long
   dwYSize As Long
   dwXCountChars As Long
   dwYCountChars As Long
   dwFillAttribute As Long
   dwFlags As Long
   wShowWindow As Integer
   cbReserved2 As Integer
   lpReserved2 As Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
   End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
   End Type

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
   lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
   lpStartupInfo As STARTUPINFO, lpProcessInformation As _
   PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long

Dim nDC As Long

Private Sub Form_Load()
   Dim myProg As String, aParams() As String
   Dim i As Integer
   Dim oldX As Long, oldY As Long, oldColours As Long, oldRefresh As Long
   Dim x As Long, y As Long, bits As Long, freq As Long

   frmMain.Hide ' don't show user this wrapper

   ' check params
   aParams = Split(Command$, " ")
   If (UBound(aParams) < 4) Then
      MsgBox "Invalid Parameters!" & vbCrLf & vbCrLf _
           & "SetVideoMode <WIDTH> <HEIGHT> <COLOURS> <FREQ> <PROG> [ARGS]" & vbCrLf _
           & "  WIDTH   : in Pixels (i.e. 640)" & vbCrLf _
           & "  HEIGHT  : in Pixels (i.e. 480)" & vbCrLf _
           & "  COLOURS : bits of colour depth (4,8,16,24,32 or 0=don't change)" & vbCrLf _
           & "  FREQ    : monitor refresh rate (0=don't change)" & vbCrLf _
           & "  PROG    : executable to run" & vbCrLf _
           & "  ARGS    : optional arguments to executable" & vbCrLf & vbCrLf _
           & "Example:  SetVideoMode 640 480 0 0 c:\apps\oldgame.exe"
      Unload Me
      Exit Sub
      End If
   
   If Dir(aParams(4)) = "" Then
      MsgBox "Unable to find program!" & vbCrLf & vbCrLf & aParams(4)
      Unload Me
      Exit Sub
      End If

   ' build our command line
   myProg = ""
   For i = 4 To UBound(aParams)
      myProg = myProg & aParams(i) & " "
      Next i

   'Create a GLOBAL device context
   nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
   
   'save the screen's current settings
   oldX = Screen.Width / Screen.TwipsPerPixelX
   oldY = Screen.Height / Screen.TwipsPerPixelY
   oldColours = GetDeviceCaps(nDC, BITSPIXEL)
   oldRefresh = GetDeviceCaps(nDC, VREFRESH)

   ' process command line settings
   x = Val(aParams(0))
   y = Val(aParams(1))
   bits = Val(aParams(2))
   If (bits = 0) Then bits = oldColours
   freq = Val(aParams(3))
   If (freq = 0) Then freq = oldRefresh
   
   'Change the screen's resolution, run the app, restore res
   ChangeRes x, y, bits, freq
   ExecCmd myProg
   ChangeRes oldX, oldY, oldColours, oldRefresh
   
   DeleteDC nDC 'delete our device context
   Unload Me
End Sub

Private Sub ChangeRes(x As Long, y As Long, bits As Long, freq As Long)
   Dim DevM As DEVMODE, ScInfo As Long, erg As Long, an As VbMsgBoxResult

   'populate DevM with current settings
   erg = EnumDisplaySettings(0&, 0&, DevM)

   'update desired fields
   DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL Or DM_DISPLAYFREQUENCY
   DevM.dmPelsWidth = x
   DevM.dmPelsHeight = y
   DevM.dmBitsPerPel = bits
   DevM.dmDisplayFrequency = freq

   'Now change the display and check if possible
   erg = ChangeDisplaySettings(DevM, CDS_TEST)

   'Check if succesfull
   Select Case erg&
      Case DISP_CHANGE_RESTART
         an = MsgBox("Reboot now to take effect?", _
            vbYesNo + vbSystemModal, "Info")
         If an = vbYes Then erg& = ExitWindowsEx(EWX_REBOOT, 0&)
      Case DISP_CHANGE_SUCCESSFUL
         erg = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
         ScInfo = y * 2 ^ 16 + x

         'Notify all the windows of the screen resolution change
         SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal bits, ByVal ScInfo
      Case Else
         MsgBox "Mode not supported", vbOKOnly + vbSystemModal, "Error"
      End Select
End Sub

Private Sub ExecCmd(cmdline$)
   Dim proc As PROCESS_INFORMATION
   Dim start As STARTUPINFO
   Dim ret As Long

   ' Initialize the STARTUPINFO structure:
   start.cb = Len(start)

   ' Start the shelled application:
   ret = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

   ' Wait for the shelled application to finish:
   ret = WaitForSingleObject(proc.hProcess, INFINITE)
   Call GetExitCodeProcess(proc.hProcess, ret&)
   Call CloseHandle(proc.hThread)
   Call CloseHandle(proc.hProcess)
End Sub

Back to Visual Basic (Microsoft) Versions 5/6 FAQ Index
Back to Visual Basic (Microsoft) Versions 5/6 Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close