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 :)
Related
I have to edit an old legacy VB6 application so that it can edit the registry to write the following:
reg add "HKCU\Software\Microsoft\Print\UnifiedPrintDialog" /v "PreferLegacyPrintDialog" /d 1 /t REG_DWORD /f
How can I emulate the above command in VB6?
I read a few posts using the registry = CreateObject("WScript.shell") methodology but it doesn't seem clear to me and I really don't want to mess around with the registry without knowing what I'm doing. Otherwise, could I just run the command through a ShellExecute or something similar?
Any assistance would be appreciated. Thanks!
For "proper" registry access/read/write in VB6, you would need to implement the appropriate Win32 API methods. Here's a wrapper class for that. But for your simple need, the WScript.Shell approach should it (from the Windows Scripting Host helpfile):
RegWrite supports strType as REG_SZ, REG_EXPAND_SZ, REG_DWORD, and
REG_BINARY. If another data type is passed as strType, RegWrite
returns E_INVALIDARG.
RegWrite automatically converts anyValue to a string when strType is
REG_SZ or REG_EXPAND_SZ. If strType is REG_DWORD, anyValue is
converted to an integer. If strType is REG_BINARY, anyValue must be an
integer.
Example
The following example writes a value and key entry into the
registry:
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.RegWrite "HKCU\ScriptEngine\Value", "Some string value"
WshShell.RegWrite "HKCU\ScriptEngine\Key\", 1 ,"REG_DWORD"
You can use the Windows API to accomplish what you need. Here's some general purpose code to read and write to the Registry:
Option Explicit
Private Sub Read_Click()
Text1.Text = ReadRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Print\UnifiedPrintDialog", "PreferLegacyPrintDialog", ValDWord, "1")
End Sub
Private Sub Write_Click()
WriteRegistry HKEY_CURRENT_USER, "Software\Microsoft\Print\UnifiedPrintDialog", "PreferLegacyPrintDialog", ValDWord, Text1.Text
End Sub
In a Module place the following code:
Option Explicit
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const REG_SZ = 1
Public Const REG_DWORD = 4
Public Enum InTypes
ValNull = 0
ValString = 1
ValXString = 2
ValBinary = 3
ValDWord = 4
ValLink = 6
ValMultiString = 7
ValResList = 8
End Enum
Private Const ERROR_SUCCESS = 0&
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
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
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
Public Function ReadRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, ByVal ValType As InTypes, Optional Default As Variant) As Variant
If ValType = ValString Then
ReadRegistry = ReadString(Group, Section, Key)
If ReadRegistry = "" Then ReadRegistry = Default
ElseIf ValType = ValDWord Then
ReadRegistry = ReadDword(Group, Section, Key)
If ReadRegistry = 0 Then ReadRegistry = Default
End If
End Function
Public Sub WriteRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, ByVal ValType As InTypes, ByVal Value As Variant)
If ValType = ValString Then
WriteString Group, Section, Key, CStr(Value)
ElseIf ValType = ValDWord Then
WriteDword Group, Section, Key, CLng(Value)
End If
End Sub
Private Function ReadString(hKey As Long, strPath As String, strValue As String) As String
Dim keyhand As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
Dim lValueType As Long
Dim r As Long
r = RegOpenKey(hKey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
If intZeroPos > 0 Then
ReadString = Left$(strBuf, intZeroPos - 1)
Else
ReadString = strBuf
End If
End If
End Function
Private Sub WriteString(hKey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(hKey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Private Function ReadDword(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String) As Long
Dim lResult As Long
Dim lValueType As Long
Dim lBuf As Long
Dim lDataBufSize As Long
Dim r As Long
Dim keyhand As Long
r = RegOpenKey(hKey, strPath, keyhand)
lDataBufSize = 4
lResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_DWORD Then ReadDword = lBuf
End If
r = RegCloseKey(keyhand)
End Function
Private Sub WriteDword(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(hKey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)
r = RegCloseKey(keyhand)
End Function
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 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.
I'm attempting to code up a call to GetProcessImageFileName in a VB6 application, but an getting...
Run-time error '453':
Can't find DLL entry point GetProcessImageFileName in PSAPI.DLL
I am given to understand it is to be found in PSAPI.DLL from the documentation here.
My code looks like...
Public Declare Function GetProcessImageFileName Lib "PSAPI.DLL" _
(ByVal hProcess As Long, _
lpImageName As String, _
ByVal nSize As Long) As Long
Public Sub MySub()
Dim name_length As Long
Dim image_name As String
...fill in process handle...
name_length = GetProcessImageFileName(process_handle, image_name, 1024)
Does anyone know what I should be doing here?
I'm running on Windows XP.
EDIT As suggested by JosephH, I have changed the code to use GetProcessImageFileNameA, thus...
Public Declare Function GetProcessImageFileNameA Lib "PSAPI.DLL" _
(ByVal hProcess As Long, _
lpImageName As String, _
ByVal nSize As Long) As Long
and
name_length = GetProcessImageFileNameA(process_handle, image_name, 1024)
Doing this (it's the same with the W version) causes the program and the VB6 development environment to crash, so there's another problem hiding in here somewhere.
It should be either GetProcessImageFileNameA or GetProcessImageFileNameW. Most Windows API function(except GetProcAddress) that accepts string as an argument has two prototypes, one with ANSI (with A suffix) and one with unicode (with W suffix)
Public Declare Function GetProcessImageFileName Lib "PSAPI.DLL" Alias "GetProcessImageFileNameA" _
(hProcess As Long, _
ByVal lpImageName As String, _
nSize As Long) As Long
name_length = GetProcessImageFileNameA(process_handle, image_name, 1024)
I am displaying Japanese characters in a VB6 application with the system locale set to Japan and the language for non Unicode programs as Japanese. A call to GetACP() correctly returns 932 for Japanese. When I insert the Japanese strings into my controls they display as “ƒAƒtƒŠƒJ‚Ì—‰¤” rather than “アフリカの女王”. If I manually set the Font.Charset to 128 then they display correctly.
What is the best way to determine the correct Charset for a given LCID in VB6?
Expanding Bob's answer, here's some code to get the current default charset.
Private Const LOCALE_SYSTEM_DEFAULT As Long = &H800
Private Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004
Private Const TCI_SRCCODEPAGE = 2
Private Type FONTSIGNATURE
fsUsb(4) As Long
fsCsb(2) As Long
End Type
Private Type CHARSETINFO
ciCharset As Long
ciACP As Long
fs As FONTSIGNATURE
End Type
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" ( _
ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long _
) As Long
Private Declare Function TranslateCharsetInfo Lib "GDI32" ( _
lpSrc As Long, _
lpcs As CHARSETINFO, _
ByVal dwFlags As Long _
) As Long
Public Function GetCharset() As Long
On Error GoTo ErrorHandler
Dim outlen As Long
Dim lCodepage As Long
Dim outBuffer As String
Dim cs As CHARSETINFO
outBuffer = String$(10, vbNullChar)
outlen = GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_IDEFAULTANSICODEPAGE, outBuffer, Len(outBuffer))
If outlen > 0 Then
lCodepage = val(Left$(outBuffer, outlen - 1))
If TranslateCharsetInfo(ByVal lCodepage, cs, TCI_SRCCODEPAGE) Then
GetCharset = cs.ciCharset
End If
End If
Exit Function
ErrorHandler:
GetCharset = 0
End Function
See http://www.microsoft.com/globaldev/drintl/columns/014/default.mspx#E5B
The second best way is to use a database of fonts, font.charsets, and heuristics, such as is done here:
http://www.example-code.com/vb/vb6-display-unicode.asp
(The best way is to get off the sinking ship that is VB6)