LookUpAnswer
asked on
Need to open access database on server without updating VB
I'm returning to Access after many years and am trying to figure out how to refer to database programmatically so it is not necessary to manually update the VB code each time it is copied to the server. (It is worked on locally and then periodically copied to server -- there is not a need for a very sophisticated solution -- just one that doesn't require regular manual input.)
Currently the Database is referenced as a literal string which is then used throughout the rest of the program. I've been trying to figure out the best way to resolve this -- I think it would involve using the registry and I've tried creating the key RefLibPaths in the registry (on the local machine) and setting it up with a value name of 'database 1.mdb' and value data of "C:\Documents and Settings\smith\Desktop\dat abase 1.mdb" which seems to be the Microsoft requirement. However once I've done this I do not know own to change the content below to reference it.
Dim strDBName As String
strDBName = "C:\Documents and Settings\smith\Desktop\dat abase 1.mdb"
This is obviously something almost everyone has to do someway -- so hopefully there's a simple thing I'm missing.
Thanks
Currently the Database is referenced as a literal string which is then used throughout the rest of the program. I've been trying to figure out the best way to resolve this -- I think it would involve using the registry and I've tried creating the key RefLibPaths in the registry (on the local machine) and setting it up with a value name of 'database 1.mdb' and value data of "C:\Documents and Settings\smith\Desktop\dat
Dim strDBName As String
strDBName = "C:\Documents and Settings\smith\Desktop\dat
This is obviously something almost everyone has to do someway -- so hopefully there's a simple thing I'm missing.
Thanks
ASKER
I'm not sure how to use this information
The VB code (with no registry update) uses the string variables later in functions
I.e.
Dim strDBName As String
strDBName = "C:\Documents and Settings\smith\Desktop\dat abase 1.mdb"
...
Call RunUpdates(strDBName)
>>>>>>>>>>>>>>>>>
So I added a registry key -- RefLibPaths and added the value name of 'database 1.mdb' with a value data of "C:\Documents and Settings\smith\Desktop\dat abase 1.mdb"
but I don't know how to change my VB code to reference it..
If I add as you suggested
dim xdb as database
set xdb = dbengine.opendatabase(strD BName)
what should I set strDBName to?
Dim strDBName As String
strDBName = ??
How should I update the function calls?
Would they become Call RunUpdates(xdb)?
Thanks for you help -- if I've gone down the wrong path with the registry and there's a better way to deal with opening the database on multiple machines (i.e. with variable paths) without requiring a code change -- please let me know.
Thanks
The VB code (with no registry update) uses the string variables later in functions
I.e.
Dim strDBName As String
strDBName = "C:\Documents and Settings\smith\Desktop\dat
...
Call RunUpdates(strDBName)
>>>>>>>>>>>>>>>>>
So I added a registry key -- RefLibPaths and added the value name of 'database 1.mdb' with a value data of "C:\Documents and Settings\smith\Desktop\dat
but I don't know how to change my VB code to reference it..
If I add as you suggested
dim xdb as database
set xdb = dbengine.opendatabase(strD
what should I set strDBName to?
Dim strDBName As String
strDBName = ??
How should I update the function calls?
Would they become Call RunUpdates(xdb)?
Thanks for you help -- if I've gone down the wrong path with the registry and there's a better way to deal with opening the database on multiple machines (i.e. with variable paths) without requiring a code change -- please let me know.
Thanks
You could store the value in the Registry, or in an INI file ... or a simple text file. Personally, I'd use the registry for this, then get the value from the registry. Access includes the GetSetting adn SAveSetting functions, but they are extremely limited in their scope and may not provide what you're looking for. The code at the end of this posting will help with that.
So, let's say you store the value here:
HKeyLocalMachine\SOFTWARE\ <Company_o r_Develope r_Name>\<A ppName>
in a Key named "DBPath", you put this: "C:\Documents and Settings\smith\Desktop\dat abase 1.mdb"
Your code would look like this:
Dim strDBName As String
strDBName = REgRead("SOFTWARE\Infotrak ker\Projec tManager", "DBPath", HKLM)
You would of course have to change the values and Registry path above to "point" to the correct section of the registry.
As always, when dealing with the registry, be VERY careful ... don't muck around too much with it until you're very confident of what you're doing, since a little slip can cause devastating consequences. What you're doing here is pretty standard, but don't stray too far until you've got some experience under your belt with this.
Copy and paste the entire code block below in a Standard Module ... this is what you use to read/write to the registry
'//////// CODE START
Option Compare Database
Option Explicit
'Attribute VB_Name = "modRegistry"
' modRegistry.Bas - Declares, Subroutines and Functions for the Registry
' 1997/05/03 Copyright 1994-1997, Larry Rebich, The Bridge, Inc.
'
' Functions and Subroutines included in this module:
'
' Function RegRead Returns a value using the Supplied Key and Value Name
' Function RegWrite Write a value using the Supplied Key, Value Name and Value
' Remove the Value Name if value is null [""]
' Function RegCreate Create a Key, open the Key, then close the Key.
' This function is called by RegWrite if the key does not exist.
' There should be no reason to call this function directly.
'
' Only string data [REG_SZ] is process by these routines.
'
' For details see the comments associated with each function.
'
DefLng A-Z
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
'/these are just shortened constants ...
Public Const HKCR = &H80000000
Public Const HKCU = &H80000001
Public Const HKLM = &H80000002
Public Const HKU = &H80000003
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_FILE_NOT_FOUND& = 2
Public Const ERROR_SUCCESS& = 0
Public Const NO_ERROR& = 0
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 READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = 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 REG_OPTION_NON_VOLATILE = 0&
Public Const REG_CREATED_NEW_KEY& = 1
Public Const REG_OPENED_EXISTING_KEY& = 2
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescription As Long 'SECURITY_DESCRIPTOR
bInheritHandle As Boolean
End Type
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
lpdwDisposition As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpValueName As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" 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
' End of Declarations -------------------------- ---------- ---------- ---------- --------
Private Function RegCreate(sKey As String, Optional lngHKey As Long) As Long
'/Purpose:
'/Created: 11/24/2004 07:50 AM
'/Created By: Scott
'/Purpose:
'/Created: 11/6/2003 10:56 PM
'/Created By: Scott
' Create a key
' Returns:
' False if Fails to Create the Key
' or lDisposition:
' REG_CREATED_NEW_KEY& = 1& or 'created a new key
' REG_OPENED_EXISTING_KEY& = 2& 'key already exists
'
Dim lRtn As Integer
Dim lHKey As Long 'return handle to opened key
Dim lDisposition As Long 'disposition
Dim lpSecurityAttributes As SECURITY_ATTRIBUTES
On Error GoTo Err_RegCreate
If lngHKey <> 0 Then
lRtn = RegCreateKeyEx(lngHKey, sKey, 0&, "", REG_OPTION_NON_VOLATILE, KEY_WRITE, _
lpSecurityAttributes, lHKey, lDisposition)
Else
lRtn = RegCreateKeyEx(HKEY_CURREN T_USER, sKey, 0&, "", _
REG_OPTION_NON_VOLATILE, KEY_WRITE, lpSecurityAttributes, lHKey, lDisposition)
End If
If lRtn = ERROR_SUCCESS Then
RegCreate = lDisposition 'tell 'em if it existed or was created
lRtn = RegCloseKey(lHKey) 'close the Registry
End If 'If lRtn = ERROR_SUCCESS
Exit_RegCreate:
On Error Resume Next
Exit Function
Err_RegCreate:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basReg" & ": " & "RegCreate"
End Select
Resume Exit_RegCreate
End Function
Public Function RegRead(sKey As String, sValueName As String, Optional vntOptionalHKey As Variant) As String
'/Purpose:
'/Created: 11/6/2003 10:56 PM
'/Created By: Scott
' Returns the Value found for this Key and ValueName
' Input: Sample:
' sKey "Software\Microsoft\File Manager\Settings"
' sValueName "Face"
' Return:
' "FixedSys" or
' "" [null] if not found
'------------------------- ---------- ---------- ---------- ---------- ---------- --------
' 96/09/18 Add support for different root level key. Needed to find DAO3032.DLL in class registry. Larry.
Dim lOptionalHKey As Long '96/09/18 Can open a different area key.
Dim lKeyType As Long
Dim lHKey As Long 'return handle to opened key
Dim lpcbData As Long 'length of data in returned string
Dim sReturnedString As String 'returned string value
Dim sTemp As String 'temp string
Dim lRtn As Long 'success or not success
On Error GoTo Err_RegRead
If IsMissing(vntOptionalHKey) Then
lOptionalHKey = HKEY_CURRENT_USER 'Use current user
Else
lOptionalHKey = vntOptionalHKey 'Use the one supplied
End If 'If IsMissing(vntOptionalHKey)
lKeyType = REG_SZ 'data type is string
lRtn = RegOpenKeyEx(lOptionalHKey , sKey, 0&, KEY_READ, lHKey)
If lRtn = ERROR_SUCCESS Then
lpcbData = 1024 'get this many characters
sReturnedString = Space$(lpcbData) 'setup the buffer
lRtn = RegQueryValueEx(lHKey, sValueName, ByVal 0&, lKeyType, sReturnedString, lpcbData)
If lRtn = ERROR_SUCCESS Then
sTemp = Left$(sReturnedString, lpcbData - 1)
End If 'If lRtn = ERROR_SUCCESS
RegCloseKey lHKey
End If 'If lRtn = ERROR_SUCCESS
RegRead = sTemp
Exit_RegRead:
On Error Resume Next
Exit Function
Err_RegRead:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basReg" & ": " & "RegRead"
End Select
Resume Exit_RegRead
End Function
Public Function RegWrite(sKey As String, sValueName As String, ByVal sValue As String, Optional vntOptionalHKey As Variant) As Integer
'/Purpose:
'/Created: 11/24/2004 07:51 AM
'/Created By: Scott
'/Purpose:
'/Created: 11/6/2003 10:56 PM
'/Created By: Scott
' Input: Sample:
' sKey "Software\Microsoft\File Manager\Settings"
' sValueName "Face"
' sValue "FixedSys"
' Return:
' True if successful
'
' If the current setting is the same as the new setting then the update is bypassed.
'
' Note: If sValue = "" then sValueName is removed [deleted].
'------------------------- ---------- ---------- ---------- ---------- ---------- --------
Dim lOptionalHKey As Long '10/14/96 Can open a different area key(to register fonts). Boris
Dim lRtn As Long
Dim lKeyType As Long 'returns the key type. This function expects REG_SZ
Dim lHKey As Long 'return handle to opened key
Dim iSuccessCount As Integer
On Error GoTo Err_RegWrite
lKeyType = REG_SZ 'these routines support only string types
If IsMissing(vntOptionalHKey) Then
lOptionalHKey = HKEY_CURRENT_USER 'Use current user
Else
lOptionalHKey = vntOptionalHKey 'Use the one supplied
End If 'If IsMissing(vntOptionalHKey)
If Trim$(sValue) <> "" Then 'if there is a value then update it
RegWriteTryAgain:
lRtn = RegOpenKeyEx(lOptionalHKey , sKey, 0&, KEY_SET_VALUE, lHKey) 'open the Registry for update
If lRtn = ERROR_SUCCESS Then
lRtn = RegSetValueEx(lHKey, sValueName, 0&, lKeyType, ByVal sValue, CLng(Len(sValue) + 1)) 'update the value
If lRtn = ERROR_SUCCESS Then
iSuccessCount = iSuccessCount + 1
End If 'If lRtn = ERROR_SUCCESS
lRtn = RegCloseKey(lHKey) 'close the Registry
ElseIf lRtn = ERROR_FILE_NOT_FOUND Or lRtn = ERROR_BADKEY Then 'create it
If RegCreate(sKey, lOptionalHKey) Then 'Create it, was it successful?
GoTo RegWriteTryAgain 'Yes, go try writing again
End If 'If RegCreate(sKey)
End If 'If lRtn = ERROR_SUCCESS
Else 'Value is null, delete the key
lRtn = RegOpenKeyEx(lOptionalHKey , sKey, 0&, KEY_SET_VALUE, lHKey) 'open the Registry for update
If lRtn = ERROR_SUCCESS Then
lRtn = RegDeleteValue(lHKey, sValueName)
If lRtn = ERROR_SUCCESS Then
iSuccessCount = iSuccessCount + 1
End If 'If lRtn = ERROR_SUCCESS
lRtn = RegCloseKey(lHKey) 'close the Registry
End If 'If lRtn = ERROR_SUCCESS
End If 'If Trim$(sValue) <> ""
If iSuccessCount > 0 Then
RegWrite = True 'OK, changed
End If 'If iSuccessCount > 0
Exit_RegWrite:
On Error Resume Next
Exit Function
Err_RegWrite:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basReg" & ": " & "RegWrite"
End Select
Resume Exit_RegWrite
End Function
'////////////// CODE END
So, let's say you store the value here:
HKeyLocalMachine\SOFTWARE\
in a Key named "DBPath", you put this: "C:\Documents and Settings\smith\Desktop\dat
Your code would look like this:
Dim strDBName As String
strDBName = REgRead("SOFTWARE\Infotrak
You would of course have to change the values and Registry path above to "point" to the correct section of the registry.
As always, when dealing with the registry, be VERY careful ... don't muck around too much with it until you're very confident of what you're doing, since a little slip can cause devastating consequences. What you're doing here is pretty standard, but don't stray too far until you've got some experience under your belt with this.
Copy and paste the entire code block below in a Standard Module ... this is what you use to read/write to the registry
'//////// CODE START
Option Compare Database
Option Explicit
'Attribute VB_Name = "modRegistry"
' modRegistry.Bas - Declares, Subroutines and Functions for the Registry
' 1997/05/03 Copyright 1994-1997, Larry Rebich, The Bridge, Inc.
'
' Functions and Subroutines included in this module:
'
' Function RegRead Returns a value using the Supplied Key and Value Name
' Function RegWrite Write a value using the Supplied Key, Value Name and Value
' Remove the Value Name if value is null [""]
' Function RegCreate Create a Key, open the Key, then close the Key.
' This function is called by RegWrite if the key does not exist.
' There should be no reason to call this function directly.
'
' Only string data [REG_SZ] is process by these routines.
'
' For details see the comments associated with each function.
'
DefLng A-Z
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
'/these are just shortened constants ...
Public Const HKCR = &H80000000
Public Const HKCU = &H80000001
Public Const HKLM = &H80000002
Public Const HKU = &H80000003
Public Const ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_FILE_NOT_FOUND& = 2
Public Const ERROR_SUCCESS& = 0
Public Const NO_ERROR& = 0
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 READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = 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 REG_OPTION_NON_VOLATILE = 0&
Public Const REG_CREATED_NEW_KEY& = 1
Public Const REG_OPENED_EXISTING_KEY& = 2
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescription As Long 'SECURITY_DESCRIPTOR
bInheritHandle As Boolean
End Type
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
lpdwDisposition As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpValueName As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" 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
' End of Declarations --------------------------
Private Function RegCreate(sKey As String, Optional lngHKey As Long) As Long
'/Purpose:
'/Created: 11/24/2004 07:50 AM
'/Created By: Scott
'/Purpose:
'/Created: 11/6/2003 10:56 PM
'/Created By: Scott
' Create a key
' Returns:
' False if Fails to Create the Key
' or lDisposition:
' REG_CREATED_NEW_KEY& = 1& or 'created a new key
' REG_OPENED_EXISTING_KEY& = 2& 'key already exists
'
Dim lRtn As Integer
Dim lHKey As Long 'return handle to opened key
Dim lDisposition As Long 'disposition
Dim lpSecurityAttributes As SECURITY_ATTRIBUTES
On Error GoTo Err_RegCreate
If lngHKey <> 0 Then
lRtn = RegCreateKeyEx(lngHKey, sKey, 0&, "", REG_OPTION_NON_VOLATILE, KEY_WRITE, _
lpSecurityAttributes, lHKey, lDisposition)
Else
lRtn = RegCreateKeyEx(HKEY_CURREN
REG_OPTION_NON_VOLATILE, KEY_WRITE, lpSecurityAttributes, lHKey, lDisposition)
End If
If lRtn = ERROR_SUCCESS Then
RegCreate = lDisposition 'tell 'em if it existed or was created
lRtn = RegCloseKey(lHKey) 'close the Registry
End If 'If lRtn = ERROR_SUCCESS
Exit_RegCreate:
On Error Resume Next
Exit Function
Err_RegCreate:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basReg" & ": " & "RegCreate"
End Select
Resume Exit_RegCreate
End Function
Public Function RegRead(sKey As String, sValueName As String, Optional vntOptionalHKey As Variant) As String
'/Purpose:
'/Created: 11/6/2003 10:56 PM
'/Created By: Scott
' Returns the Value found for this Key and ValueName
' Input: Sample:
' sKey "Software\Microsoft\File Manager\Settings"
' sValueName "Face"
' Return:
' "FixedSys" or
' "" [null] if not found
'-------------------------
' 96/09/18 Add support for different root level key. Needed to find DAO3032.DLL in class registry. Larry.
Dim lOptionalHKey As Long '96/09/18 Can open a different area key.
Dim lKeyType As Long
Dim lHKey As Long 'return handle to opened key
Dim lpcbData As Long 'length of data in returned string
Dim sReturnedString As String 'returned string value
Dim sTemp As String 'temp string
Dim lRtn As Long 'success or not success
On Error GoTo Err_RegRead
If IsMissing(vntOptionalHKey)
lOptionalHKey = HKEY_CURRENT_USER 'Use current user
Else
lOptionalHKey = vntOptionalHKey 'Use the one supplied
End If 'If IsMissing(vntOptionalHKey)
lKeyType = REG_SZ 'data type is string
lRtn = RegOpenKeyEx(lOptionalHKey
If lRtn = ERROR_SUCCESS Then
lpcbData = 1024 'get this many characters
sReturnedString = Space$(lpcbData) 'setup the buffer
lRtn = RegQueryValueEx(lHKey, sValueName, ByVal 0&, lKeyType, sReturnedString, lpcbData)
If lRtn = ERROR_SUCCESS Then
sTemp = Left$(sReturnedString, lpcbData - 1)
End If 'If lRtn = ERROR_SUCCESS
RegCloseKey lHKey
End If 'If lRtn = ERROR_SUCCESS
RegRead = sTemp
Exit_RegRead:
On Error Resume Next
Exit Function
Err_RegRead:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basReg" & ": " & "RegRead"
End Select
Resume Exit_RegRead
End Function
Public Function RegWrite(sKey As String, sValueName As String, ByVal sValue As String, Optional vntOptionalHKey As Variant) As Integer
'/Purpose:
'/Created: 11/24/2004 07:51 AM
'/Created By: Scott
'/Purpose:
'/Created: 11/6/2003 10:56 PM
'/Created By: Scott
' Input: Sample:
' sKey "Software\Microsoft\File Manager\Settings"
' sValueName "Face"
' sValue "FixedSys"
' Return:
' True if successful
'
' If the current setting is the same as the new setting then the update is bypassed.
'
' Note: If sValue = "" then sValueName is removed [deleted].
'-------------------------
Dim lOptionalHKey As Long '10/14/96 Can open a different area key(to register fonts). Boris
Dim lRtn As Long
Dim lKeyType As Long 'returns the key type. This function expects REG_SZ
Dim lHKey As Long 'return handle to opened key
Dim iSuccessCount As Integer
On Error GoTo Err_RegWrite
lKeyType = REG_SZ 'these routines support only string types
If IsMissing(vntOptionalHKey)
lOptionalHKey = HKEY_CURRENT_USER 'Use current user
Else
lOptionalHKey = vntOptionalHKey 'Use the one supplied
End If 'If IsMissing(vntOptionalHKey)
If Trim$(sValue) <> "" Then 'if there is a value then update it
RegWriteTryAgain:
lRtn = RegOpenKeyEx(lOptionalHKey
If lRtn = ERROR_SUCCESS Then
lRtn = RegSetValueEx(lHKey, sValueName, 0&, lKeyType, ByVal sValue, CLng(Len(sValue) + 1)) 'update the value
If lRtn = ERROR_SUCCESS Then
iSuccessCount = iSuccessCount + 1
End If 'If lRtn = ERROR_SUCCESS
lRtn = RegCloseKey(lHKey) 'close the Registry
ElseIf lRtn = ERROR_FILE_NOT_FOUND Or lRtn = ERROR_BADKEY Then 'create it
If RegCreate(sKey, lOptionalHKey) Then 'Create it, was it successful?
GoTo RegWriteTryAgain 'Yes, go try writing again
End If 'If RegCreate(sKey)
End If 'If lRtn = ERROR_SUCCESS
Else 'Value is null, delete the key
lRtn = RegOpenKeyEx(lOptionalHKey
If lRtn = ERROR_SUCCESS Then
lRtn = RegDeleteValue(lHKey, sValueName)
If lRtn = ERROR_SUCCESS Then
iSuccessCount = iSuccessCount + 1
End If 'If lRtn = ERROR_SUCCESS
lRtn = RegCloseKey(lHKey) 'close the Registry
End If 'If lRtn = ERROR_SUCCESS
End If 'If Trim$(sValue) <> ""
If iSuccessCount > 0 Then
RegWrite = True 'OK, changed
End If 'If iSuccessCount > 0
Exit_RegWrite:
On Error Resume Next
Exit Function
Err_RegWrite:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basReg" & ": " & "RegWrite"
End Select
Resume Exit_RegWrite
End Function
'////////////// CODE END
Note that if you want user to be able to grab this value from a remote machine, you can't use this code ... this would only work on the local workstation. If you'd rather put something on a mapped drive or server for all users to "look" at, you'd probably be better off with an INI file. You can use the code below (again, copy/paste to a standard module) and call it like this:
dim strDB As String
strDB = GetINI("//Server1/MyDirect ory/DBSett ings.ini", "MyDb", "Path")
Assuming you have an INI file named DBSettings that looks like this:
[MyDb]
Path=C:\SomeDir\MyDB.mdb
you'll be able to retrieve it ...
"??????????? Code Start
Option Compare Database
Option Explicit
Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileString A" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Function WriteINI(iniFileName As String, INISection As String, INISetting As String, ValueToWrite As String) As Boolean
'/Purpose:
'/Created: 10/10/2004 07:25 AM
'/Created By: Scott
Dim RetVal As Long
On Error GoTo Err_WriteINI
RetVal = WritePrivateProfileString( INISection , INISetting, ValueToWrite, iniFileName)
Exit_WriteINI:
On Error Resume Next
Exit Function
Err_WriteINI:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basINIRoutines" & ": " & "WriteINI"
End Select
Resume Exit_WriteINI
End Function
Function GetINI(iniFileName As String, INISection As String, INISetting As String) As String
'/Purpose:
'/Created: 10/10/2004 07:26 AM
'/Created By: Scott
Dim mvarData As String ' receives the value read from the INI file
Dim lngLength As Long ' receives length of the returned string
On Error GoTo Err_GetINI
mvarData = Space(255) ' provide enough room for the function to put the value into the buffer
' Read from the INI file
lngLength = GetPrivateProfileString(IN ISection, INISetting, "none", mvarData, 255, iniFileName)
mvarData = Left(mvarData, lngLength) ' extract the returned string from the buffer
GetINI = mvarData
Exit_GetINI:
On Error Resume Next
Exit Function
Err_GetINI:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basINIRoutines" & ": " & "GetINI"
End Select
Resume Exit_GetINI
End Function
dim strDB As String
strDB = GetINI("//Server1/MyDirect
Assuming you have an INI file named DBSettings that looks like this:
[MyDb]
Path=C:\SomeDir\MyDB.mdb
you'll be able to retrieve it ...
"??????????? Code Start
Option Compare Database
Option Explicit
Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA"
Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileString
Function WriteINI(iniFileName As String, INISection As String, INISetting As String, ValueToWrite As String) As Boolean
'/Purpose:
'/Created: 10/10/2004 07:25 AM
'/Created By: Scott
Dim RetVal As Long
On Error GoTo Err_WriteINI
RetVal = WritePrivateProfileString(
Exit_WriteINI:
On Error Resume Next
Exit Function
Err_WriteINI:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basINIRoutines" & ": " & "WriteINI"
End Select
Resume Exit_WriteINI
End Function
Function GetINI(iniFileName As String, INISection As String, INISetting As String) As String
'/Purpose:
'/Created: 10/10/2004 07:26 AM
'/Created By: Scott
Dim mvarData As String ' receives the value read from the INI file
Dim lngLength As Long ' receives length of the returned string
On Error GoTo Err_GetINI
mvarData = Space(255) ' provide enough room for the function to put the value into the buffer
' Read from the INI file
lngLength = GetPrivateProfileString(IN
mvarData = Left(mvarData, lngLength) ' extract the returned string from the buffer
GetINI = mvarData
Exit_GetINI:
On Error Resume Next
Exit Function
Err_GetINI:
Select Case Err
'case
Case Else
MsgBox Err & ":" & Error$, vbCritical, "basINIRoutines" & ": " & "GetINI"
End Select
Resume Exit_GetINI
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
are you making your UI with Access or VB?
if you can deal with the default location of the built-in registry functions you will use a lot less code :-)
Delete program settings. DeleteSetting
Read program settings. GetSetting, GetAllSettings
Save program settings. SaveSetting
Steve
if you can deal with the default location of the built-in registry functions you will use a lot less code :-)
Delete program settings. DeleteSetting
Read program settings. GetSetting, GetAllSettings
Save program settings. SaveSetting
Steve
ASKER
Thanks Pete -- Currentproject.Fullname did the trick.
dim xdb as database
set xdb = dbengine.opendatabase(strD
regards,
-jadedata-