I am trying to modify specific registry keys, but it will only work when I debug the application not after I build it.
I find this very weird so I am turning to you guys for help.
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 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
Private Const BM_CLICK = &HF5
Const REG_DWORD = 4
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const REGKEY = "Software\Microsoft\Windows\CurrentVersion\Policies\system"
Const KEY_WRITE = &H20006
Dim Path As Long
Dim Value As Long
Sub TASK()
On Error GoTo hell:
Value = 1
If RegOpenKeyEx(HKEY_CURRENT_USER, REGKEY, 0, KEY_WRITE, Path) Then Exit Sub
RegSetValueEx Path, NameOfKey, 0, REG_DWORD, Value, Len(Value)
Exit Sub
hell:
MsgBox Err & Error(Err)
End Sub
Sub UAC()
On Error GoTo hell:
Value = 0
If RegOpenKeyEx(HKEY_LOCAL_MACHINE, REGKEY, 0, KEY_WRITE, Path) Then Exit Sub
RegSetValueEx Path, "ConsentPromptBehaviorAdmin", 0&, REG_DWORD, Value, Len(Value)
Exit Sub
hell:
MsgBox Err & Error(Err)
End Sub
I am sure it is just something very small that I am missing.
This may not solve all your issues, but it is something important to consider:
If RegOpenKeyEx(HKEY_LOCAL_MACHINE, REGKEY, 0, KEY_WRITE, Path) Then Exit Sub
You cannot write to HKEY_LOCAL_MACHINE unless you are an Administrator. In XP this will throw an error and fail, I believe. I believe that Vista and Win7 handle this differently. I think in Vista and Win7 the write is virtualized in the user's profile and no error is thrown. The entry is stored not in HKEY_LOCAL_MACHINE but in what is called the Virtual Store. These versions of Windows also can virtualized file access to protected system files through this service.
http://msdn.microsoft.com/en-us/library/windows/desktop/aa965884(v=vs.85).aspx
also #6 in this article...
http://blogs.msdn.com/b/chinmay_palei/archive/2011/01/16/windows-7-application-compatibility-issues-fix-centre.aspx
Is it possible that you have set your VB IDE to run as Administrator? This would cause your debug session to run as Admin, but when you are running the EXE on it's own it would run as user? Either way, this line will definately cause errors for your users.
Related
Error 127 is 'ERROR_PROC_NOT_FOUND' ('The specified procedure could not be found').
I'm running on a Windows Server 2016 running Citrix XenApp with Remote Desktop Services. The CryptAcquireContext API is in advapi32.dll. I ran Microsoft's Depends32.exe on it, and the function CryptAcquireContextA and CryptAcquireContextW are definitely in the DLL file. Same error seems to happen with all the crypto api functions. I tested CryptDestroyHash and it also returns an error of 127 (ERROR_PROC_NOT_FOUND).
Here is my C++ code:
HCRYPTPROV hProv = 0;
BOOL bCryptAcquireContext = CryptAcquireContext(&hProv, NULL, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, 0);
dwError = GetLastError();
This C++ does work in an EXE, but if the same code is put into a DLL that is called from VB6, it does not work. It's almost like any vb6 app is blocked from those APIs?
Here is the VB6 code:
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Sub Form_Load()
Dim sProvider As String
Dim rv as Long
Dim sContainer As String
Dim m_lProvider As Long
Const PROV_RSA_FULL = 1
Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Const MS_DEF_PROV As String = "Microsoft Base Cryptographic Provider v1.0"
sProvider = MS_DEF_PROV & vbNullChar
sContainer = vbNullChar
rv = CryptAcquireContext(m_lProvider, 0, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)
dwError = Err.LastDllError
If rv = 0 and dwError <> 127 Then
rv = CryptAcquireContext(m_lProvider, 0&, ByVal sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)
End If
End Sub
You're passing a Long to a parameter (pszContainer) you defined to be a string:
Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
Alias "CryptAcquireContextA" _
(ByRef phProv As Long, ByVal pszContainer As String, _
ByVal pszProvider As String, ByVal dwProvType As Long, _
ByVal dwFlags As Long) As Long
rv = CryptAcquireContext(m_lProvider, 0, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)
Try this instead (also for the 2nd call of CryptAcquireContext):
rv = CryptAcquireContext(m_lProvider, vbNullString, MS_ENH_RSA_AES_PROV, PROV_RSA_AES, CRYPT_VERIFYCONTEXT)
I can say that I observed similar issue at a customer machine (error code 127 - ERROR_PROC_NOT_FOUND - set by CryptAcquireContextA Windows API function). Googling led me to the http://tracker.firebirdsql.org/browse/CORE-6154 page where the same issue was discussed. The page said that the issue "was solved Updating Windows Server 2016 with Windows Update". The customer I worked with reported that the issue disappeared after Windows updates were installed.
I have the following VB6 code which tries to enumerate registry subkeys. This works on all machines I tried it on, except for one new Windows 7 VM that I'm trying to setup as a dev machine.
This is Windows 7 pro, with all updates made. VB6 with SP6.
The keys that I'm trying to enumerate definitely exist. However, on the new VM I'm getting error 87 - "The parameter is incorrect", when calling RegQueryInfoKey.
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As Any) As Long
Private Sub Command1_Click()
Dim lResult As Long
Dim hKey As Long
Dim cJunk As Long
Dim cNameMax As Long
Dim ft As Currency
lResult = RegOpenKeyEx(&H80000001, "Software\Speedocs\[...]", 0, &H1, hKey)
If (lResult = ERROR_SUCCESS) Then
MsgBox RegQueryInfoKey(hKey, "", cJunk, 0, cJunk, cJunk, cJunk, cJunk, cNameMax, cJunk, cJunk, ft)
End If
End Sub
Just for anyone who ever comes across this: the problem was that VB6 was used in Compatibility Mode (specifically for Windows XP). I am running VB6 on a Windows 7 machine. I remember reading somewhere that VB6 must be used in compatibility mode, and therefore had set it to Windows XP Compatibility. Once I unchecked Compatibility Mode all together, the problem had been solved.
I have a small VB6 app in which I use the Shell command to execute a program. I am storing the output of the program in a file. I am then reading this file and putting the output on the screen using a msgbox in VB6.
This is what my code looks like now:
sCommand = "\evaluate.exe<test.txt "
Shell ("cmd.exe /c" & App.Path & sCommand)
MsgBox Text2String(App.Path & "\experiments\" & genname & "\freq")
The problem is that the output which the VB program is printing using the msgbox is the old state of the file. Is there some way to hold the execution of the VB code until my shell command program finishes so that I get the correct state of the output file and not a previous state?
The secret sauce needed to do this is the WaitForSingleObject function, which blocks execution of your application's process until the specified process completes (or times out). It's part of the Windows API, easily called from a VB 6 application after adding the appropriate declaration to your code.
That declaration would look something like this:
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle _
As Long, ByVal dwMilliseconds As Long) As Long
It takes two parameters: a handle to the process that you want to wait on, and the time-out interval (in milliseconds) that indicates the maximum amount of time that you want to wait. If you do not specify a time-out interval (a value of zero), the function does not wait and returns immediately. If you specify an infinite time-out interval, the function returns only when the process signals that it has completed.
Armed with that knowledge, the only task that remains is figuring out how to get a handle to the process that you started. That turns out to be pretty simple, and can be accomplished a number of different ways:
One possibility (and the way I'd do it) is by using the ShellExecuteEx function, also from the Windows API, as a drop-in replacement for the Shell function that is built into VB 6. This version is far more versatile and powerful, yet just as easily called using the appropriate declaration.
It returns a handle to the process that it creates. All you have to do is pass that handle to the WaitForSingleObject function as the hHandle parameter, and you're in business. Execution of your application will be blocked (suspended) until the process that you've called terminates.
Another possibility is to use the CreateProcess function (once again, from the Windows API). This function creates a new process and its primary thread in the same security context as the calling process (i.e., your VB 6 application).
Microsoft has published a knowledge base article detailing this approach that even provides a complete sample implementation. You can find that article here: How To Use a 32-Bit Application to Determine When a Shelled Process Ends.
Finally, perhaps the simplest approach yet is to take advantage of the fact that the built-in Shell function's return value is an application task ID. This is a unique number that identifies the program you started, and it can be passed to the OpenProcess function to obtain a process handle that can be passed to the WaitForSingleObject function.
However, the simplicity of this approach does come at a cost. A very significant disadvantage is that it will cause your VB 6 application to become completely unresponsive. Because it will not be processing Windows messages, it will not respond to user interaction or even redraw the screen.
The good folks over at VBnet have made complete sample code available in the following article: WaitForSingleObject: Determine when a Shelled App has Ended.
I'd love to be able to reproduce the code here to help stave off link rot (VB 6 is getting up there in years now; there's no guarantee that these resources will be around forever), but the distribution license in the code itself appears to explicitly forbid that.
There is no need to resort to the extra effort of calling CreateProcess(), etc. This more or less duplicates the old Randy Birch code though it wasn't based on his example. There are only so many ways to skin a cat.
Here we have a prepackaged Function for handy use, which also returns the exit code. Drop it into a static (.BAS) module or include it inline in a Form or Class.
Option Explicit
Private Const INFINITE = &HFFFFFFFF&
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_QUERY_INFORMATION = &H400&
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 Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Public Function ShellSync( _
ByVal PathName As String, _
ByVal WindowStyle As VbAppWinStyle) As Long
'Shell and wait. Return exit code result, raise an
'exception on any error.
Dim lngPid As Long
Dim lngHandle As Long
Dim lngExitCode As Long
lngPid = Shell(PathName, WindowStyle)
If lngPid <> 0 Then
lngHandle = OpenProcess(SYNCHRONIZE _
Or PROCESS_QUERY_INFORMATION, 0, lngPid)
If lngHandle <> 0 Then
WaitForSingleObject lngHandle, INFINITE
If GetExitCodeProcess(lngHandle, lngExitCode) <> 0 Then
ShellSync = lngExitCode
CloseHandle lngHandle
Else
CloseHandle lngHandle
Err.Raise &H8004AA00, "ShellSync", _
"Failed to retrieve exit code, error " _
& CStr(Err.LastDllError)
End If
Else
Err.Raise &H8004AA01, "ShellSync", _
"Failed to open child process"
End If
Else
Err.Raise &H8004AA02, "ShellSync", _
"Failed to Shell child process"
End If
End Function
I know it's an old thread, but...
How about using the Windows Script Host's Run method? It has a bWaitOnReturn parameter.
object.Run (strCommand, [intWindowStyle], [bWaitOnReturn])
Set oShell = CreateObject("WSCript.shell")
oShell.run "cmd /C " & App.Path & sCommand, 0, True
intWindowStyle = 0, so cmd will be hidden
Do like this :
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
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&
Public Function ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
' 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
Sub Form_Click()
Dim retval As Long
retval = ExecCmd("notepad.exe")
MsgBox "Process Finished, Exit Code " & retval
End Sub
Reference : http://support.microsoft.com/kb/129796
Great code. Just one tiny little problem: you must declare in the ExecCmd (after Dim start As STARTUPINFO):
Dim ret as Long
You will get an error when trying to compile in VB6 if you don't.
But it works great :)
Kind regards
In my hands, the csaba solution hangs with intWindowStyle = 0, and never passes control back to VB. The only way out is to end process in taskmanager.
Setting intWindowStyle = 3 and closing the window manually passes control back
I've found a better & simpler solution:
Dim processID = Shell("C:/path/to/process.exe " + args
Dim p As Process = Process.GetProcessById(processID)
p.WaitForExit()
and then you just continue with your code.
Hope it helps ;-)
Other than looping from 1 to 32 and trying open each of them, is there a reliable way to get COM ports on the system?
I believe under modern windows environments you can find them in the registry under the following key HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM. I'm not sure of the correct way to specify registry keys. However I have only ever tested this on Windows XP.
Check out this article from Randy Birch's site: CreateFile: Determine Available COM Ports
There's also the approach of using an MSCOMM control: ConfigurePort: Determine Available COM Ports with the MSCOMM Control
The code's a bit too long for me to post here but the links have everything you need.
It's 1 to 255. Fastest you can do it is using QueryDosDevice like this
Option Explicit
'--- for CreateFile
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const OPEN_EXISTING As Long = 3
Private Const INVALID_HANDLE_VALUE As Long = -1
'--- error codes
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const ERROR_GEN_FAILURE As Long = 31&
Private Const ERROR_SHARING_VIOLATION As Long = 32&
Private Const ERROR_SEM_TIMEOUT As Long = 121&
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As Long, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Function PrintError(sFunc As String)
Debug.Print sFunc; ": "; Error
End Function
Public Function IsNT() As Boolean
IsNT = True
End Function
Public Function EnumSerialPorts() As Variant
Const FUNC_NAME As String = "EnumSerialPorts"
Dim sBuffer As String
Dim lIdx As Long
Dim hFile As Long
Dim vRet As Variant
Dim lCount As Long
On Error GoTo EH
ReDim vRet(0 To 255) As Variant
If IsNT Then
sBuffer = String$(100000, 1)
Call QueryDosDevice(0, sBuffer, Len(sBuffer))
sBuffer = Chr$(0) & sBuffer
For lIdx = 1 To 255
If InStr(1, sBuffer, Chr$(0) & "COM" & lIdx & Chr$(0), vbTextCompare) > 0 Then
vRet(lCount) = "COM" & lIdx
lCount = lCount + 1
End If
Next
Else
For lIdx = 1 To 255
hFile = CreateFile("COM" & lIdx, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, 0, 0)
If hFile = INVALID_HANDLE_VALUE Then
Select Case Err.LastDllError
Case ERROR_ACCESS_DENIED, ERROR_GEN_FAILURE, ERROR_SHARING_VIOLATION, ERROR_SEM_TIMEOUT
hFile = 0
End Select
Else
Call CloseHandle(hFile)
hFile = 0
End If
If hFile = 0 Then
vRet(lCount) = "COM" & lIdx
lCount = lCount + 1
End If
Next
End If
If lCount = 0 Then
EnumSerialPorts = Split(vbNullString)
Else
ReDim Preserve vRet(0 To lCount - 1) As Variant
EnumSerialPorts = vRet
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume Next
End Function
The snippet falls back to CreateFile on 9x. IsNT function is stubbed for brevity.
Using VB6 or VBScript to enumerate available COM ports can be as simple as using VB.NET, and this can be done by enumerating values from registry path HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM. It's better than calling QueryDosDevice() and doing string comparison to filter out devices which's name is leading by COM since you will get something like CompositeBattery (or other stuff which have full upper case name leading by COM) that isn't a COM port. Another benefit of doing this is that the registry values also containing USB to COM devices, which could not be detected by using the codes such as WMIService.ExecQuery("Select * from Win32_SerialPort"). If you try to plug the USB to COM devices in or out of the computer, you can see the registry values also appear or disappear immediately, since it's keeping updated.
Option Explicit
Sub ListComPorts()
List1.Clear
Dim Registry As Object, Names As Variant, Types As Variant
Set Registry = GetObject("winmgmts:\\.\root\default:StdRegProv")
If Registry.EnumValues(&H80000002, "HARDWARE\DEVICEMAP\SERIALCOMM", Names, Types) <> 0 Then Exit Sub
Dim I As Long
If IsArray(Names) Then
For I = 0 To UBound(Names)
Dim PortName As Variant
Registry.GetStringValue &H80000002, "HARDWARE\DEVICEMAP\SERIALCOMM", Names(I), PortName
List1.AddItem PortName & " - " & Names(I)
Next
End If
End Sub
Private Sub Form_Load()
ListComPorts
End Sub
The code above is using StdRegProv class to enumerate the values of a registry key. I've tested the code in XP, Windows 7, Windows 10, and it works without any complainant. The items which were added to the Listbox looks like below:
COM1 - \Device\Serial0
COM3 - \Device\ProlificSerial0
The downside of this code is that it could not detect which port is already opened by other programs since every port could only be opened once. The way to detect a COM port is opened by another program or not can be done by calling the API CreateFile. Here is an example.
Basically the same as this question, but for VB6.
A customer's application "AppName" has
its configuration files stored in
CommonAppData.
Under Windows XP that is C:\Documents and Settings\All
Users\Application Data\AppName
Under Windows Vista that is C:\ProgramData\AppName
How do I get the correct foldername with VB6??
Additional notes, I prefer to use a API Call instead of adding a reference to the shell32.dll
Use late binding:
Const ssfCOMMONAPPDATA = &H23
Dim strCommonAppData As String
strCommonAppData = _
CreateObject("Shell.Application").NameSpace(ssfCOMMONAPPDATA).Self.Path
found it;
Private Declare Function SHGetFolderPath _
Lib "shfolder.dll" Alias "SHGetFolderPathA" _
(ByVal hwndOwner As Long, _
ByVal nFolder As Long, _
ByVal hToken As Long, _
ByVal dwReserved As Long, _
ByVal lpszPath As String) As Long
Private Const CSIDL_COMMON_APPDATA = &H23
Private Const CSIDL_COMMON_DOCUMENTS = &H2E
Public Function strGetCommonAppDataPath() As String
Dim strPath As String
strPath = Space$(512)
Call SHGetFolderPath(0, CSIDL_COMMON_APPDATA, 0, 0, strPath)
strPath = Left$(strPath, InStr(strPath, vbNullChar))
strGetCommonAppDataPath = strPath
End Function
Karl Peterson has published a drop-in VB6 class called CSystemFolders that will find CSIDL_APPDATA, CSIDL_LOCAL_APPDATA and CSIDL_COMMON_APPDATA.
Karl's code is always reliable, accept no substitutes :)