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
|