Print Page | Close Window

Change resolution when playing and come b

Printed From: Mirage Source
Category: Tutorials
Forum Name: Temporary Archive (Read Only)
Forum Discription: Temporary 3.0.3 archive tutorials, will be deleted when converted.
URL: http://ms.shannaracorp.com/backup-forums/forum_posts.asp?TID=181
Printed Date: 20 December 2006 at 5:52pm
Software Version: Web Wiz Forums 8.01 - http://www.webwizforums.com


Topic: Change resolution when playing and come b
Posted By: Sync
Subject: Change resolution when playing and come b
Date Posted: 11 February 2006 at 3:20pm
This code is for change resolution.
Really simple =)

FIRST

Creat a new Module and call it MODULE1.

Add this in.


Option Explicit

Public Enum RegRoot
   HKEY_CLASSES_ROOT = &H80000000
   HKEY_CURRENT_USER = &H80000001
   HKEY_LOCAL_MACHINE = &H80000002
   HKEY_USERS = &H80000003
   HKEY_DYN_DATA = &H80000004
   HKEY_CURRENT_CONFIG = &H80000005
End Enum
'API nécessaires
Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long

'pour créer ou ouvrir une clé
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
    (ByVal hKey As Long, _
     ByVal lpSubKey As String, _
     phkResult As Long) As Long
     
'pour supprimer une clé
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, _
     ByVal lpSubKey As String) As Long
    
'pour supprimer une valeur
 Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
    (ByVal hKey As Long, _
     ByVal lpSubKey As String) As Long
    
'pour lire une valeur
 Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, _
     ByVal lpValueName As String, _
     ByVal lpReserved As Long, _
     lpType As Long, _
     lpData As Any, _
     lpcbData As Long) As Long
    
'pour fixer ou créer une valeur
 Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
    (ByVal hKey As Long, _
     ByVal lpValueName As String, _
     ByVal Reserved As Long, _
     ByVal dwType As Long, _
     lpData As Any, _
     ByVal cbData As Long) As Long
 Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Public Function CreateKey(Root As RegRoot, Clé As String)
   Dim Resultat As Integer
   Dim Ident As Long
Resultat = 0
Resultat = RegCreateKey(Root, Clé, Ident)
Resultat = RegCloseKey(Root)
End Function

Public Function DeleteKey(ByVal Root As RegRoot, ByVal Emplacement As String, ByVal Clé As String) '***** suppression d'une clé *****
   Dim Resultat As Integer
   Dim Ident As Long
   
    Resultat = 0    'on suppose que tout marchera bien
   
    'on ouvre la clé (en faisant comme si on la créait),
    'et on obtient ainsi un identificateur stocké dans Ident
    'qui nous permettra de supprimer la clé
   
    Resultat = RegCreateKey(Root, Emplacement, Ident)
   
    If Resultat = 0 Then    's'il n'a pas eu d'erreur à l'ouverture de la clé ; c'est à dire que Resultat est toujours égal à 0
        Resultat = RegDeleteKey(Ident, Clé)  'suppression de la clé
    End If
    Resultat = RegCloseKey(Root)
End Function

Public Function SetValue(ByVal Root As RegRoot, ByVal Clé As String, ByVal Valeur As String, Donnée As String) '***** créer ou fixer une valeur *****
   Dim Resultat As Integer
   Dim Ident As Long
   
    Resultat = 0
   
    'on ouvre la clé (en faisant comme si on la créait),
    'et on obtient ainsi un identificateur stocké dans Ident
    'qui nous permettra d'accéder à la clé
  
    Resultat = RegCreateKey(Root, Clé, Ident)
   
    If Resultat = 0 Then
        'Fixe la valeur avec la donnée qui correspond
        'Si la valeur n'existe pas, elle sera automatiquement crée.
        Resultat = RegSetValueEx(Ident, Valeur, 0&, 1, ByVal Donnée, Len(Donnée) + 1)
    End If
    Resultat = RegCloseKey(Root)
End Function

Public Function GetValue(ByVal Root As RegRoot, ByVal Clé As String, ByVal Valeur As String) As String '***** lire une valeur *****
   Dim Resultat As Integer
   Dim TailleBuffer As Long
   Dim Ident As Long
   Dim Donnee As String

    Resultat = 0    'on suppose que tout marchera bien pour l'ouverture de la clé
   
    'on ouvre la clé (en faisant comme si on la créait),
    'et on obtient ainsi un identificateur stocké dans Ident
    'qui nous permettra d'accéder à la clé
    Resultat = RegCreateKey(Root, Clé, Ident)
      
    If Resultat <> 0 Then   's'il y'a eu une erreur à l'ouverture de la clé
        Exit Function 'sortir
    End If
   
    'Détermine la taille de la donnée de la valeur à lire
    Resultat = RegQueryValueEx(Ident, Valeur, 0&, 1, 0&, TailleBuffer)
                    
    If TailleBuffer < 2 Then    'c'est à dire qu'il n'y a que le caractère null (ou alors rien du tout)
        'Pas de donnée à lire
        GetValue = ""
        Exit Function
    End If
   
    'Alloue à "Donnee" la taille nécessaire pour stocker la donnée de la valeur
    Donnee = String(TailleBuffer + 1, " ")  'Nombre de caractères plus un pour le caractère null qui est mis à la fin
   
    'Trouve la donnée de la valeur
    Resultat = RegQueryValueEx(Ident, Valeur, 0&, 1, ByVal Donnee, TailleBuffer)
   
    'Retire le caractère null final
    Donnee = Left(Donnee, TailleBuffer - 1)
    GetValue = Donnee
    Resultat = RegCloseKey(Root)
End Function

Public Function DeleteValue(ByVal Root As RegRoot, ByVal Clé As String, ByVal Valeur As String) '***** Supprimer une valeur *****
   Dim Resultat As Integer
   Dim Ident As Long
   
    Resultat = 0    'toujours la même chose (voir au dessus)
   
    Resultat = RegCreateKey(Root, Clé, Ident)  'idem
   
    If Resultat = 0 Then    'on se répète, vous ne trouvez pas ?
        Resultat = RegDeleteValue(Ident, ByVal Valeur) 'suppression de la valeur
    End If


Resultat = RegCloseKey(Root)
End Function

'Public Sub EnumRegKeys(ByRef returnName As Collection, Optional ByRef returnSubs As Collection, Optional hKeyName As String = "HKEY_LOCAL_MACHINE", Optional keyname As String = "SOFTWARE", Optional ByVal checkForSubs As Boolean = False)
'Public Sub EnumRegKeys(ByVal Root As RegRoot, ByVal Clé As String, ByRef ReturnName As Collection, Optional ByVal CheckForSubs As Boolean = False, Optional ReturnSubs As Collection)
'        Dim lRetVal As Long         'result of the API functions
'        Dim lngResult2 As Long          'result of the API functions
'        Dim hKey2 As Long
'        Dim hKey As Long         &n bsp;       'handle of opened key
'        Dim vValue As Variant       'setting of queried value
'        Dim lngKeyHandle As Long
'        Dim lngResult As Long
'        Dim lngCurIdx As Long
'        Dim strValue As String
'        Dim lngValueLen As Long
'        Dim lngData As Long
'        Dim lngDataLen As Long
'        Dim strResult As String
'        Dim lKeyName As Long
'        Dim SubLevel As Boolean
'        Dim keyname As String
'        Set ReturnName = New Collection
'        Set ReturnSubs = New Collection
'
''        keyname = CompileKeyString(keyname)
'         keyname = Clé
'         lKeyName = Root
''        lKeyName = HKEY_LOCAL_MACHINE
'
'        Do
'           ;      lRetVal = RegOpenKeyEx(lKeyName, keyname, 0, KEY_READ, hKey)
'           ;      lngValueLen = 2000
'           ;      strValue = String(lngValueLen, 0)
'           ;      lngDataLen = 2000
'           ;      lngResult = RegEnumKey(hKey, lngCurIdx, ByVal strValue, lngValueLen)
'           ;      lngCurIdx = lngCurIdx + 1
'           ;      RegCloseKey (hKey)
'
'           ;      If lngResult = ERROR_SUCCESS Then
'                           strResult = Left(strValue, lngValueLen)
'                           If InStr(1, strResult, Chr(0) & Chr(0) & Chr(0) & Chr(0), vbTextCompare) <> 0 Then
'                                    strResult = Mid(strResult, 1, InStr(1, strResult, Chr(0) & Chr(0) & Chr(0) & Chr(0), vbTextCompare) - 1)
'                           Else
'                                    strResult = strResult
'                           End If
'                           If CheckForSubs = True Then
'                                    If keyname = "" Then
'                                             lngResult2 = RegOpenKeyEx(lKeyName, strResult, 0, KEY_READ, hKey2)
'                                    Else
'                                             lngResult2 = RegOpenKeyEx(lKeyName, keyname & "\" & strResult, 0, KEY_READ, hKey2)
'                                    End If
'                                    strValue = String(lngValueLen, 0)
'                                    lngResult2 = RegEnumKey(hKey2, 0, ByVal strValue, lngValueLen)
'                                    RegCloseKey (hKey2)
'                                    If lngResult2 = ERROR_SUCCESS Then
'                                             SubLevel = True
'                                    Else
'                                             SubLevel = False
'                                    End If
'                                    ReturnSubs.Add SubLevel
'                           End If
'                           ReturnName.Add strResult
'           ;      End If
'        Loop While lngResult = ERROR_SUCCESS
'
'
'End Sub
'

Sub MAINs()
   Call Resolution
End Sub


------------------------Now Creat a new Module and call it mdlChangeRes

Add this in
Option Explicit
Global Const ReqResX = 800
Global Const ReqResY = 600
Global Const ReqCoul = 32
Global Const CléPrim = HKEY_LOCAL_MACHINE
Global Const CléSec = "SOFTWARE\TestRes"
Global CurResX As Integer, CurResY As Integer, CurCoul As Integer
Global MustChangeRes As Boolean


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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Type DEVMODE
   dmDeviceName As String * 32
   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 * 32
   dmUnusedPadding As Integer
   dmBitsPerPel As Integer
   dmPelsWidth As Long
   dmPelsHeight As Long
   dmDisplayFlags As Long
   dmDisplayFrequency As Long
End Type
Public Enum EnumSetRes
   SUCCES = 0
   ECHEC = -2
End Enum


'Fenêtre au premier plan
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, Optional ByVal X As Long = 0, Optional ByVal Y As Long = 0, Optional ByVal cx As Long = 0, Optional ByVal cy As Long = 0, Optional ByVal wFlags As Long = 3) As Long
Public Enum SetWndPosConst
WND_TOPMOST = -1
WND_NOTOPMOST = -2
End Enum

Public Function SetWndPos(Fenêtre As Form, Position As SetWndPosConst)
Dim dummy As Long
dummy = SetWindowPos(Fenêtre.hWnd, Position, 0, 0, 0, 0, 3)
End Function

Public Function GetNbCoul() As Integer
   Dim dmEcran As DEVMODE
   Dim blTMP As Boolean
   blTMP = EnumDisplaySettings(0, -1, dmEcran)
   GetNbCoul = dmEcran.dmBitsPerPel
End Function
Public Function GetResX() As Integer
   Dim dmEcran As DEVMODE
   EnumDisplaySettings 0, -1, dmEcran
   GetResX = dmEcran.dmPelsWidth
'   GetResX = Screen.Width \ Screen.TwipsPerPixelX
End Function
Public Function GetResY() As Integer
   Dim dmEcran As DEVMODE
   EnumDisplaySettings 0, -1, dmEcran
   GetResY = dmEcran.dmPelsHeight
'   GetResY = Screen.Height \ Screen.TwipsPerPixelY
End Function
Public Function SetRes(ByVal RezX As Single, ByVal RezY As Single, ByVal NbCoul As Integer) As EnumSetRes
'    If RezX = GetResX And RezY = GetResY And NbCoul = GetNbCoul Then Exit Function
    Dim dmEcran As DEVMODE
    Dim blTMP As Boolean, lgTMP As Long
    blTMP = EnumDisplaySettings(0, -1, dmEcran)
    If RezX = dmEcran.dmPelsWidth And RezY = dmEcran.dmPelsHeight And NbCoul = dmEcran.dmBitsPerPel Then Exit Function
    'dmEcran.dmFields = 1835008
    If RezX <> dmEcran.dmPelsWidth Then dmEcran.dmFields = &H80000
    If RezY <> dmEcran.dmPelsHeight Then dmEcran.dmFields = dmEcran.dmFields Or &H100000
    If NbCoul <> dmEcran.dmBitsPerPel Then dmEcran.dmFields = dmEcran.dmFields Or &H100000
    dmEcran.dmPelsWidth = RezX
    dmEcran.dmPelsHeight = RezY
    dmEcran.dmBitsPerPel = NbCoul
    Call ChangeDisplaySettings(dmEcran, 1)
    blTMP = SendMessage(65535, 27, 0, 0)
    Dim ScInfo As Long
    ScInfo = RezY * 2 ^ 16 + RezX
    SendMessage &HFFFF&, &H7E, ByVal NbCoul, ByVal ScInfo
    SetRes = lgTMP
End Function

Public Sub Resolution()
   CurResX = GetResX
   CurResY = GetResY
   CurCoul = GetNbCoul
   If CurResX <> ReqResX Or CurResY <> ReqResY Or CurCoul <> ReqCoul Then
      If GetValue(CléPrim, CléSec, "AutoChangeRes") = "OK" Then
         Call SetRes(ReqResX, ReqResY, ReqCoul)
      Else
         If CurResX < ReqResX Or CurResY < ReqResY Or CurCoul < ReqCoul Then
             MustChangeRes = True
         Else
             MustChangeRes = False
         End If
         If MustChangeRes = False Then
             If GetValue(CléPrim, CléSec, "PasAff") = "OK" Then Exit Sub
         End If
         Load frmChangeRes
         Unload frmChangeRes
      End If
   End If
End Sub

Public Sub RestaureRes()
   Call SetRes(CurResX, CurResY, CurCoul)
End Sub


----------------------------

And now you only need to add Call resolution in a button or where you want.

EXEMPLE

Go in ModClientTcp
Sub TcpInit

YOU WILL SEE THIS


Sub TcpInit()
    SEP_CHAR = Chr(0)
    END_CHAR = Chr(237)
    PlayerBuffer = ""
       
    frmMirage.Socket.RemoteHost = "192.168.1.100"
    frmMirage.Socket.RemotePort = GAME_PORT
End Sub


Only add CALL RESOLUTION before End Sub

So the resolution will change when the game will load.

AND NOW
--------------
You will need to add

Call SetRes(CurResX, CurResY, CurCoul)


In your QUIT button. (frmMirage) (FrmMainMenu)


That's it =p



Print Page | Close Window

Bulletin Board Software by Web Wiz Forums version 8.01 - http://www.webwizforums.com
Copyright ©2001-2006 Web Wiz Guide - http://www.webwizguide.info