[RESOLVED] [VB6] Strange bug?

Sup flokes,

When i run this code in IDE mode it will work. But when i run it just in windows after i compiled it it wont work at all.

Tested under Windows 7 Ult 64-bit and Win 7 Perm 64-bit SP1
Both executed as Administrator.

This is a fix for Far Cry 2 for Windows 7 Custom maps.

Sub:

Code:

---

Private Sub CMD1_Click()
On Error Resume Next

Dim steamexe As String

steamexe = GetStringValue("HKEY_CURRENT_USER\Software\Valve\Steam", "SteamExe")
Dim tps As String
tps = Replace(steamexe, "steam.exe", "steamapps\common\far cry 2\bin")
steamexe = tps

Dim tpss As String
tpss = Replace(steamexe, "/", "\")
steamexe = tpss

'MsgBox steamexe

MsgBox "Steam version of FarCry 2 has been fixed!", vbInformation, "Fixed!"

Kill steamexe & "\winhttp.dll"

Dim file1() As Byte
file1 = LoadResData(101, "CUSTOM")
Open steamexe & "\winhttp.dll" For Binary As #1
Put #1, , file1
Close #1

End Sub

---

Read reg module:

Code:

---


Type FILETIME
    lLowDateTime    As Long
    lHighDateTime  As Long
End Type
 
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Const DisplayErrorMsg = False

Function SetBinaryValue(SubKey As String, Entry As String, Value As String)
On Error Resume Next
Call ParseKey(SubKey, MainKeyHandle)

If MainKeyHandle Then
  rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
  If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
      lDataSize = Len(Value)
      ReDim ByteArray(lDataSize)
      For i = 1 To lDataSize
      ByteArray(i) = Asc(Mid$(Value, i, 1))
      Next
      rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, ByteArray(1), lDataSize) 'write the value
      If Not rtn = ERROR_SUCCESS Then  'if the was an error writting the value
        If DisplayErrorMsg = True Then 'if the user want errors displayed
            MsgBox ErrorMsg(rtn)        'display the error
        End If
      End If
      rtn = RegCloseKey(hKey) 'close the key
  Else 'if there was an error opening the key
      If DisplayErrorMsg = True Then 'if the user wants errors displayed
        MsgBox ErrorMsg(rtn) 'display the error
      End If
  End If
End If

End Function

Function ErrorMsg(lErrorCode As Long) As String

On Error Resume Next

End Function

Function GetStringValue(SubKey As String, Entry As String)
On Error Resume Next
Call ParseKey(SubKey, MainKeyHandle)

If MainKeyHandle Then
  rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
  If rtn = ERROR_SUCCESS Then 'if the key could be opened then
      sBuffer = Space(255)    'make a buffer
      lBufferSize = Len(sBuffer)
      rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
      If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
        rtn = RegCloseKey(hKey)  'close the key
        sBuffer = Trim(sBuffer)
        GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user
      Else                        'otherwise, if the value couldnt be retreived
        GetStringValue = "Key Not found" 'return Error to the user
        If DisplayErrorMsg = True Then 'if the user wants errors displayed then
            MsgBox ErrorMsg(rtn)  'tell the user what was wrong
        End If
      End If
  Else 'otherwise, if the key couldnt be opened
      GetStringValue = "Key Not found"      'return Error to the user
      If DisplayErrorMsg = True Then 'if the user wants errors displayed then
        MsgBox ErrorMsg(rtn)        'tell the user what was wrong
      End If
  End If
End If

End Function

Private Sub ParseKey(Keyname As String, Keyhandle As Long)
On Error Resume Next
rtn = InStr(Keyname, "\") 'return if "\" is contained in the Keyname

If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then 'if the is a "\" at the end of the Keyname then
  MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname 'display error to the user
  Exit Sub 'exit the procedure
ElseIf rtn = 0 Then 'if the Keyname contains no "\"
  Keyhandle = GetMainKeyHandle(Keyname)
  Keyname = "" 'leave Keyname blank
Else 'otherwise, Keyname contains "\"
  Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1)) 'seperate the Keyname
  Keyname = Right(Keyname, Len(Keyname) - rtn)
End If

End Sub

Function SetStringValue(SubKey As String, Entry As String, Value As String)
On Error Resume Next
Call ParseKey(SubKey, MainKeyHandle)

If MainKeyHandle Then
  rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
  If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
      rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal Value, Len(Value)) 'write the value
      If Not rtn = ERROR_SUCCESS Then  'if there was an error writting the value
        If DisplayErrorMsg = True Then 'if the user wants errors displayed
            MsgBox ErrorMsg(rtn)        'display the error
        End If
      End If
      rtn = RegCloseKey(hKey) 'close the key
  Else 'if there was an error opening the key
      If DisplayErrorMsg = True Then 'if the user wants errors displayed
        MsgBox ErrorMsg(rtn)        'display the error
      End If
  End If
End If

End Function


Function GetMainKeyHandle(MainKeyName As String) As Long

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
 
Select Case MainKeyName
      Case "HKEY_CLASSES_ROOT"
            GetMainKeyHandle = HKEY_CLASSES_ROOT
      Case "HKEY_CURRENT_USER"
            GetMainKeyHandle = HKEY_CURRENT_USER
      Case "HKEY_LOCAL_MACHINE"
            GetMainKeyHandle = HKEY_LOCAL_MACHINE
      Case "HKEY_USERS"
            GetMainKeyHandle = HKEY_USERS
      Case "HKEY_PERFORMANCE_DATA"
            GetMainKeyHandle = HKEY_PERFORMANCE_DATA
      Case "HKEY_CURRENT_CONFIG"
            GetMainKeyHandle = HKEY_CURRENT_CONFIG
      Case "HKEY_DYN_DATA"
            GetMainKeyHandle = HKEY_DYN_DATA
End Select

End Function

---

What could be the problem?? I am out of ideas..

Best Regards,
NiTrOwow

It helps if you describe what "it wont work at all" means.

Does it show your messagebox?
Is an error generated?
Does the program just crash?

You are saying you are having problems on 64bit machines. Was it developed on a 64bit or 32bit machine?

Removing the On Error Resume next may give you an idea what the problem is. I'm guessing if you were to check what is being returned in steamexe you will find it isn't what you expect.

Remove the 'On Error Resume Next' statement and see what happens

Quote:

---

Originally Posted by Doogle

Remove the 'On Error Resume Next' statement and see what happens

---

Lol guys think i did copy paste work. I added that myself, why? IF the file does not exist yet it can't be deleted so it sneeds to resume on that error.. And no i have removed anything and tried it all over again. No message box nothing. Just doesn't work, just wont create or open the file. And i used this method so many freaking times and it always worked this is the first time it only works in IDE mode.

What happens if you remove the line Doogle mentioned above then run the code in the IDE debug mode?

Quote:

---

Originally Posted by Nightwalker83

What happens if you remove the line Doogle mentioned above then run the code in the IDE debug mode?

---

As i said before nothing heppens. The file would be created.
And it gives err 75 file path not found or something because of kill if the file is not there without on error resume next etc.

Which line is highlighted when the error occurs?

There's another 'On Error Resume Next' in Function GetStringValue. I'd remove that and see what happens. By the way, you're not testing the result from GetStringValue, just assuming it all ran OK. Note that it can return a value "Key Not found" instead of the Key's value.

Saying all that I'd still expect the MsgBox to be executed.

Quote:

---

Originally Posted by Doogle

There's another 'On Error Resume Next' in Function GetStringValue. I'd remove that and see what happens. By the way, you're not testing the result from GetStringValue, just assuming it all ran OK. Note that it can return a value "Key Not found" instead of the Key's value.

Saying all that I'd still expect the MsgBox to be executed.

---

Thats what i all tested, the output of the string with messagebox before i use it for opening the file and putting the data of the resource file in it.

Quote:

---

Originally Posted by Nightwalker83

Which line is highlighted when the error occurs?

---

Shows nothing in IDE. It just works in IDE mode. While i compile it wont work and just not create the file at all. And yes i tried to test ANYTHING you guys said.

Try doing a little logging and see what happens.

Code:

---


Private Sub CMD1_Click()
      Dim steamexe As String
      Dim tps As String
      Dim tpss As String
      Dim file1() As Byte


10        On Error GoTo CMD1_Click_Error
   
20        steamexe = GetStringValue("HKEY_CURRENT_USER\Software\Valve\Steam", "SteamExe")

30        tps = Replace(steamexe, "steam.exe", "steamapps\common\far cry 2\bin")
40        steamexe = tps


50        tpss = Replace(steamexe, "/", "\")
60        steamexe = tpss

70        Kill steamexe & "\winhttp.dll"

80        MsgBox "Steam version of FarCry 2 has been fixed!", vbInformation, "Fixed!"

   
90        file1 = LoadResData(101, "CUSTOM")
   
100      Open steamexe & "\winhttp.dll" For Binary As #1
110          Put #1, , file1
120      Close #1

130  Exit Sub

CMD1_Click_Error:

      LogError "Error " & Err.Number & " (" & Err.Description & ") in procedure CMD1_Click of Form Form1" & vbCrLf & "Error on line number " & Erl
      Resume Next
End Sub


Private Sub LogError(strError)
Dim strErrLog As String
Dim ff As Integer

    strErrLog = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\") & "ErrorLog.txt"
    ff = FreeFile
   
    Open strErrLog For Append As ff
        Print #ff, strError
        Print #ff, ""
    Close ff
End Sub

---

Just throwing this out there, but Windows since Vista has been picky about where you can delete and write files. Could it be the OS simply does not like where you are trying to write the dll? One thing I picked up early on with VB6 under Vista/7 is it needs to run ad admin, which makes what you do in the IDE less strict than a compiled exe, which if it does not have admin privs, will not output data as efficiently as could be done pre Vista.

- Kev

Error 53 (File not found) in procedure CMD1_Click of Form Form1
Error on line number 70
(Obvious, Kill steamexe & "\winhttp.dll")

Error 75 (Path/File access error) in procedure CMD1_Click of Form Form1
Error on line number 100
(Open steamexe & "\winhttp.dll" For Binary As #1)

Error 52 (Bad file name or number) in procedure CMD1_Click of Form Form1
Error on line number 110
(Obvious, 110 Put #1, , file1) Can't put the data in the file if the path string isn't right or good.

The string output is not good. Thats the problem i guess.

Screenshot:
http://wss-data.com/i/9AEF5488C.png

lol vb!
The solution was:
Using a textbox instead of a string. And the wierd thing is.
It works in IDE mode, with the string. But not after i compiled it.

Code:

---

50        tpss = Replace(steamexe, "/", "\")
60        steamexe = tpss
          Text1.Text = steamexe

70        Kill steamexe & "\winhttp.dll"

80      'MsgBox "Steam version of FarCry 2 has been fixed!", vbInformation, "Fixed!"

    MsgBox Text1.Text
90        file1 = LoadResData(101, "CUSTOM")
   
100      Open Text1.Text & "\winhttp.dll" For Binary As #1
110          Put #1, , file1
120      Close #1

130  Exit Sub

---

Thanks to MarKT and all others that tried to help :) Thanks!

Hi Everyone,
Sorry for the interruption, May I know, What is the use of these numbers (10, 20, 30, 40) before syntax?

Like:

Code:

---

10        On Error GoTo CMD1_Click_Error
   
20        steamexe = GetStringValue("HKEY_CURRENT_USER\Software\Valve\Steam", "SteamExe")

30        tps = Replace(steamexe, "steam.exe", "steamapps\common\far cry 2\bin")
40        steamexe = tps

---

Thanks :)

Regards,

Quote:

---

Originally Posted by green.pitch

Hi Everyone,
Sorry for the interruption, May I know, What is the use of these numbers (10, 20, 30, 40) before syntax?

Like:

Code:

---

10        On Error GoTo CMD1_Click_Error
   
20        steamexe = GetStringValue("HKEY_CURRENT_USER\Software\Valve\Steam", "SteamExe")

30        tps = Replace(steamexe, "steam.exe", "steamapps\common\far cry 2\bin")
40        steamexe = tps

---

Thanks :)

Regards,

---

It has already been solved. I forgot to edit the thread.

Regards.

Quote:

---

It works in IDE mode, with the string. But not after i compiled it.

---

Please read the post I made about why this might be.

Ya Sorry @NiTrOwow YES the Thread has been solved, I just wanted to know the use of these numbers (10, 20, 30, 40) you using in your codes syntax. I'v seen such coding styles, But donot know the concept behind these bullet numbering.

-Regards,

Quote:

---

Originally Posted by green.pitch

Ya Sorry @NiTrOwow YES the Thread has been solved, I just wanted to know the use of these numbers (10, 20, 30, 40) you using in your codes syntax. I'v seen such coding styles, But donot know the concept behind these bullet numbering.

-Regards,

---

Lol dude that is the error/debug log. To write to ErrorLog.txt why are you even asking in above posts you see the whole code. It's obvious..

Quote:

---

Originally Posted by KProvance

Please read the post I made about why this might be.

---

If i already don't know that. And the method i use always worked on Windows 7 and vista. It wasn't the problem, if it was then i replied to you to thank you. Btw don't have to run it as administrator to extraxt the file out of the resource. I have UAC and DEP disabled on my machine.

Sry forgot to quote this in post 18#.

While you may have fixed this using a TextBox I suspect the real problem is in the registry code and you can get rid of the TextBox:

Code:

---

  sBuffer = Trim(sBuffer)
  GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user

---

You should NOT be using Trim here. Try this:

Code:

---

GetStringValue = StripNull(sBuffer)

Public Function StripNull(StrIn As String) As String
  Dim nul              As Long
  nul = InStr(StrIn, vbNullChar)
  If (nul) Then
      StripNull = Left$(StrIn, nul - 1)
  Else
      StripNull = Trim$(StrIn)
  End If
End Function

---

Quote:

---

Originally Posted by DrUnicode

While you may have fixed this using a TextBox I suspect the real problem is in the registry code and you can get rid of the TextBox:

Code:

---

  sBuffer = Trim(sBuffer)
  GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user

---

You should NOT be using Trim here. Try this:

Code:

---

GetStringValue = StripNull(sBuffer)

Public Function StripNull(StrIn As String) As String
  Dim nul              As Long
  nul = InStr(StrIn, vbNullChar)
  If (nul) Then
      StripNull = Left$(StrIn, nul - 1)
  Else
      StripNull = Trim$(StrIn)
  End If
End Function

---

---

Nah, there was no nullbyte in the string at all. Not in the start or end. I have tested this all. textbox does it's job fine. I have hidden it, and works like it has to work lol.