Option Strict Off
Option Explicit On
Module BasMain
'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/05/2011 Refined the code to remove unnecessary code.
' Also, remove the need for a form the code only requires a module to run.
'Update: 16/05/2011 Modified the code to use dynamic paths instead of hard coded paths.
'Update: 18/05/2011 Added a function to copy the source files to a new directory if the user is using xliveless.
'Update: 20/05/2011 Added function to retrieve the folder name of the folder containing the save files
'Update: 26/05/2011 Added command-line functions
'Update: 16/07/2011 Added code to adjust the default frame rate
'Update: 30/07/2011 The code now includes a sub to detect if the target program is still responding
' Added GTA IV icon
'Author: Aaron Spehr
'Alias: Nightwalker83
'Website: http://aaronspehr.net/
Private source, destination As String
Private c, sNextFile, MyName As String
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Integer, ByVal nFolder As Integer, ByRef ppidl As Integer) As Integer
Private Declare Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Integer, ByVal lpBuffer As String) As Integer
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Integer)
Const CSIDL_PERSONAL As Integer = &H5 '(user)\My Documents
Const CSIDL_LOCAL_APPDATA As Integer = &H1C '(user)\Local Settings\Application Data
Private Structure STARTUPINFO
Dim cb As Integer
Dim lpReserved As String
Dim lpDesktop As String
Dim lpTitle As String
Dim dwX As Integer
Dim dwY As Integer
Dim dwXSize As Integer
Dim dwYSize As Integer
Dim dwXCountChars As Integer
Dim dwYCountChars As Integer
Dim dwFillAttribute As Integer
Dim dwFlags As Integer
Dim wShowWindow As Short
Dim cbReserved2 As Short
Dim lpReserved2 As Integer
Dim hStdInput As Integer
Dim hStdOutput As Integer
Dim hStdError As Integer
End Structure
Public Structure PROCESS_INFORMATION
Dim hProcess As Integer
Dim hThread As Integer
Dim dwProcessId As Integer
Dim dwThreadID As Integer
End Structure
Public Declare Function WaitForSingleObject Lib "Kernel32" (ByVal hHandle As Integer, ByVal dwMilliseconds As Integer) As Integer
'API Constants
Const SMTO_BLOCK As Integer = &H1
Const SMTO_ABORTIFHUNG As Integer = &H2
Const WM_NULL As Integer = &H0
Const WM_CLOSE As Integer = &H10
Const PROCESS_ALL_ACCESS As Integer = &H1F0FFF
'API functions
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA"(ByVal hWnd As Integer, ByVal msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer, ByVal fuFlags As Integer, ByVal uTimeout As Integer, ByRef lpdwResult As Integer) As Integer
'UPGRADE_WARNING: Structure PROCESS_INFORMATION may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
'UPGRADE_WARNING: Structure STARTUPINFO may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function CreateProcessA Lib "Kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Integer, ByVal lpThreadAttributes As Integer, ByVal bInheritHandles As Integer, ByVal dwCreationFlags As Integer, ByVal lpEnvironment As Integer, ByVal lpCurrentDirectory As String, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Integer
Public Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Integer) As Integer
Private Declare Function GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Integer, ByRef lpExitCode As Integer) As Integer
Private Const NORMAL_PRIORITY_CLASS As Integer = &H20
Private Const INFINITE As Short = -1
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Integer
Private Structure OSVERSIONINFO
Dim dwOSVersionInfoSize As Integer
Dim dwMajorVersion As Integer
Dim dwMinorVersion As Integer
Dim dwBuildNumber As Integer
Dim dwPlatformId As Integer
'UPGRADE_WARNING: Fixed-length string size must fit in the buffer. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
<VBFixedString(128),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray,SizeConst:=128)> Public szCSDVersion() As Char
End Structure
Private Const OF_EXIST As Integer = &H4000
Private Const OFS_MAXPATHNAME As Integer = 128
Private Const HFILE_ERROR As Integer = -1
Private Structure OFSTRUCT
Dim cBytes As Byte
Dim fFixedDisk As Byte
Dim nErrCode As Short
Dim Reserved1 As Short
Dim Reserved2 As Short
<VBFixedArray(OFS_MAXPATHNAME)> Dim szPathName() As Byte
'UPGRADE_TODO: "Initialize" must be called to initialize instances of this structure. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="B4BFF9E0-8631-45CF-910E-62AB3970F27B"'
Public Sub Initialize()
ReDim szPathName(OFS_MAXPATHNAME)
End Sub
End Structure
'UPGRADE_WARNING: Structure OFSTRUCT may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function OpenFile Lib "Kernel32" (ByVal lpFileName As String, ByRef lpReOpenBuff As OFSTRUCT, ByVal wStyle As Integer) As Integer
Private Function FileExists(ByVal Fname As String) As Boolean
'http://www.vbforums.com/showthread.php?t=349990
Dim lRetVal As Integer
'UPGRADE_WARNING: Arrays in structure OfSt may need to be initialized before they can be used. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="814DF224-76BD-4BB4-BFFB-EA359CB9FC48"'
Dim OfSt As OFSTRUCT
lRetVal = OpenFile(Fname, OfSt, OF_EXIST)
If lRetVal <> HFILE_ERROR Then
FileExists = True
Else
FileExists = False
End If
End Function
Private Function ExecCmd(ByRef cmdline As String) As Object
' 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)
'UPGRADE_WARNING: Couldn't resolve default property of object ExecCmd. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
ExecCmd = ret
End Function
Public Sub MainLoader()
Dim retval As Integer
Dim lngResult As Integer
Dim lngReturnValue As Integer
'Replace the path and app.name.type with that of the application you want to use
'UPGRADE_WARNING: Couldn't resolve default property of object ExecCmd(). Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
retval = ExecCmd("LaunchGTAIV.exe")
lngReturnValue = SendMessageTimeout(0, WM_NULL, 0, 0, SMTO_ABORTIFHUNG And SMTO_BLOCK, 1000, lngResult)
System.Windows.Forms.Application.DoEvents()
If lngReturnValue Then
Call GetPath()
Call command_Renamed()
Game_Loop()
Else
'Close the host and the client if the client does not respond
System.Windows.Forms.Application.DoEvents()
Running = False
Call GetExitCodeProcess(proc.hProcess, ret)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
frmAbout.Close()
End If
End Sub
Private Function GetSpecialFolder(ByVal lCSIDL As Integer) As String
Const S_OK As Integer = 0
Const MAX_PATH As Integer = 260
Dim sPath As String
Dim lIdl As Integer
If SHGetSpecialFolderLocation(0, lCSIDL, lIdl) = S_OK Then
sPath = Space(MAX_PATH)
If SHGetPathFromIDList(lIdl, sPath) Then
CoTaskMemFree(lIdl)
GetSpecialFolder = Left(sPath, InStr(sPath, vbNullChar) - 1)
End If
End If
End Function
Private Function GetPath() As Object
'UPGRADE_WARNING: Dir has a new behavior. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
If Dir(My.Application.Info.DirectoryPath & "\dsound.dll") <> "" Then
source = GetSpecialFolder(CSIDL_LOCAL_APPDATA) & "\Rockstar Games\GTA IV\"
destination = GetSpecialFolder(CSIDL_PERSONAL) & "\Rockstar Games\GTA IV\"
Else
source = GetSpecialFolder(CSIDL_LOCAL_APPDATA) & "\Rockstar Games\GTA IV\"
destination = GetSpecialFolder(CSIDL_LOCAL_APPDATA) & "\Rockstar Games\GTA IV\"
End If
Call Delete(source)
If Not source = destination Then Call Copy(source)
End Function
Private Sub Delete(ByRef source As Object)
'Deletes the default settings files
Dim d As String
'UPGRADE_WARNING: Couldn't resolve default property of object source. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
d = source & "Settings\"
'UPGRADE_WARNING: Dir has a new behavior. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
sNextFile = Dir(d & "*.*", FileAttribute.Normal + FileAttribute.Hidden + FileAttribute.ReadOnly)
Do While sNextFile <> ""
SetAttr(d & sNextFile, FileAttribute.Normal)
Kill((d & sNextFile))
'UPGRADE_WARNING: Dir has a new behavior. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
sNextFile = Dir()
Loop
End Sub
Private Sub Copy(ByRef source As Object)
'UPGRADE_WARNING: Couldn't resolve default property of object source. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
c = source & "savegames\"
destination = destination & "savegames\"
Call lastFolder(c)
End Sub
Private Sub lastFolder(ByRef c As Object)
Dim Mypath, e As String
Dim iCount As Short
iCount = 0
MyName = ""
'UPGRADE_WARNING: Couldn't resolve default property of object c. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
Mypath = c ' Set the path.
'UPGRADE_WARNING: Dir has a new behavior. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
MyName = Dir(Mypath, FileAttribute.Directory) ' Retrieve the first entry.
Do While MyName <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName <> "." And MyName <> ".." And Not MyName = "user_invalid" Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(Mypath & MyName) And FileAttribute.Directory) = FileAttribute.Directory Then
iCount = iCount + 1
'UPGRADE_WARNING: Couldn't resolve default property of object c. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
e = c & MyName
Call VBCopyFolder(e, destination) ' it represents a directory.
End If
End If
'UPGRADE_WARNING: Dir has a new behavior. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
MyName = Dir() ' Get next entry.
Loop
End Sub
'UPGRADE_NOTE: command was upgraded to command_Renamed. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
Private Sub command_Renamed()
'Paste commandline.txt in the same directory as GTAIV
Dim ff As Short
ff = FreeFile
FileOpen(ff, My.Application.Info.DirectoryPath & "\" & "commandline.txt", OpenMode.Output)
PrintLine(ff, "-Width 1280" & vbCrLf & "-Height 720" & vbCrLf & "-texturequality 1" & vbCrLf & "-shadowdensity 3" & vbCrLf & "-viewdistance 25" & vbCrLf & "-detailquality 30" & vbCrLf & "-norestrictions" & vbCrLf & "-novblank" & vbCrLf & "- safemode" & vbCrLf & "-fullscreen" & vbCrLf & "-windowed" & vbCrLf & "-availablevidmem 1.5" & vbCrLf & "-percentvidmem 0.5" & vbCrLf & "-frameLimit 1" & vbCrLf & "-refreshrate 60" & vbCrLf & "-fullspecaudio" & vbCrLf & "-minspecaudio" & vbCrLf & "-noprecache" & vbCrLf & "- nomemrestrict" & vbCrLf & "- benchmark" & vbCrLf & "- help")
FileClose(ff)
End Sub
Public Sub response()
Dim ret As Integer
ret = WaitForSingleObject(proc.hProcess, 500)
If ret = 0 Then
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
Call GetExitCodeProcess(proc.hProcess, ret)
End If
End Sub
End Module
