'Description: checks the system for the default GTA IV settings files
'and deletes them so you can play the game using the controls you define.
'Date: 04/05/2011
'Update 07/04/2011 Refined the code to remove unnecessary code.
' Also, remove the need for a form the code only requires a module to run.
'Author: Aaron Spehr
'Alias: Nightwalker83
'Website: http://aaronspehr.net/
Option Explicit
Private sUserName As String
Private path As String
'Used to get the username of the currently logged in account
Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'Used to get the operating system version
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
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 WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
'API Constants
Const SMTO_BLOCK = &H1
Const SMTO_ABORTIFHUNG = &H2
Const WM_NULL = &H0
Const WM_CLOSE = &H10
Const PROCESS_ALL_ACCESS = &H1F0FFF
'API functions
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" _
(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As _
Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, 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 String, _
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
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret&
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Function ExecCmd(cmdline$)
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, 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)
ExecCmd = ret&
End Function
Private Sub Main()
Dim retval As Long
Dim lngResult As Long
Dim lngReturnValue As Long
CurrentUser
WinVersion
'Replace the path and app.name.type with that of the application you want to use
retval = ExecCmd("GTAIV.exe")
lngReturnValue = SendMessageTimeout(0, WM_NULL, 0&, 0&, SMTO_ABORTIFHUNG And SMTO_BLOCK, 1000, lngResult)
DoEvents
If Not lngReturnValue Then
'Close the host and the client if the client does not respond
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
'Unload Me
End If
End Sub
Private Sub WinVersion()
'Retrive the current operating system and set the settings path accordingly
'http://social.msdn.microsoft.com/Forums/en/vbide/thread/395b12fd-ccfc-4281-b1b3-4c69b56f8b85
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
If osinfo.dwMajorVersion = 7 Then 'Windows 7
path = "C:\Users\" + sUserName + "\AppData\Local\Rockstar Games\GTA IV\Settings\"
ElseIf osinfo.dwMajorVersion = 6 Then 'Vista
path = "C:\Users\" + sUserName + "\AppData\Local\Rockstar Games\GTA IV\Settings\"
'MsgBox (path)
ElseIf osinfo.dwMajorVersion = 5 Then 'XP
path = "C:\Documents and Settings\" + sUserName + "\Local Settings\Application Data\Rockstar Games\GTA IV\Settings\"
'ElseIf osinfo.dwMajorVersion = 4 Then 'Win2k etc.
Else
End If
Call Delete(path)
End Sub
Public Function CurrentUser() As String
'*********************************************************
'* Function to get the current logged on user in windows *
'*********************************************************
'http://www.vbforums.com/showthread.php?t=357723
Dim strBuff As String * 255
Dim X As Long
CurrentUser = ""
X = GetUserName(strBuff, Len(strBuff) - 1)
If X > 0 Then
'Look for Null Character, usually included
X = InStr(strBuff, vbNullChar)
'Trim off buffered spaces too
If X > 0 Then
CurrentUser = UCase(Left$(strBuff, X - 1)) 'UCase is optional;)
Else
CurrentUser = UCase(Left$(strBuff, X))
End If
End If
sUserName = CurrentUser
End Function
Private Function Delete(path As String)
Dim sNextFile As String
sNextFile = Dir$(path + "*.*", vbNormal + vbHidden + vbReadOnly)
Do While sNextFile <> ""
SetAttr path & sNextFile, vbNormal
Kill (path & sNextFile)
sNextFile = Dir$
Loop
End Function
Reply With Quote