Back end mdb Registry Setting 1

[mrf3000]

Hi,

I am a VB6 programmer relatively new, but I can get around. I am looking for code so that when you first open the VB6 app, a common dialog comes up to locate the data which is on the server. The program will then store the path in the registry which will then be used for all the data controls. I understand I need to use the savesetting and getsetting methods, but I am new to registry editing and would be grateful for anyone to supply the code to read and write the path name to the registry.

Thanks,
mrf3000

 

[Transcend]

Hi there,

this is going to be really long ... but it works for me

******************************************************
copy and paste this into a class, i usually save it as CRegAPI.
******************************************************
Option Explicit
Private Const mk_sClassVersion As String = "V01.00.05"
Private Const mk_sClassName As String = "CRegAPI"
'==========================================================================
'Copyright © 1992-1997, SunOpTech®, Ltd., All Rights Reserved
'
' Program Name: cRegAPI Class
'Program Description: Routines for accessing Registry
'
' Original Author: Chris Barlow
' Modified by:
' Date Created: December 20, 1997
'
'Discussion:
'===========================================================================

Const REG_SZ As Long = 1
Const REG_BINARY = 3
Const REG_DWORD As Long = 4
Const ERROR_NONE = 0
Const ERROR_BADDB = 1
Const ERROR_BADKEY = 2
Const ERROR_CANTOPEN = 3
Const ERROR_CANTREAD = 4
Const ERROR_CANTWRITE = 5
Const ERROR_OUTOFMEMORY = 6
Const ERROR_INVALID_PARAMETER = 7
Const ERROR_ACCESS_DENIED = 8
Const ERROR_INVALID_PARAMETERS = 87
Const ERROR_NO_MORE_ITEMS = 259
Const KEY_ALL_ACCESS = &H3F
Const REG_OPTION_NON_VOLATILE = 0

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
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 lpSubKey As String, _
ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
As Long, phkResult As Long, lpdwDisposition 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 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, _
ByVal lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegQueryValueExString 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

Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long

Private Declare Function RegQueryValueExBinary Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Byte, lpcbData As Long) As Long

Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long

Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long

Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long

Private Declare Function RegSetValueExBinary Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Byte, _
ByVal cbData As Long) As Long

Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias _
"RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, _
ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegEnumValueNull Lib "advapi32.dll" Alias _
"RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, lpData As Byte, lpcbData As Long) As Long

Private Declare Function RegEnumValueString Lib "advapi32.dll" Alias _
"RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, ByVal lpValue As String, lpcbData As Long) As Long

Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias _
"RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, lpValue As Long, lpcbData As Long) As Long

Private Declare Function RegEnumValueBinary Lib "advapi32.dll" Alias _
"RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, _
lpType As Long, lpValue As Byte, lpcbData As Long) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
"RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
"RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long



Public KeyPrefix As String
Public Root As Long
Public Enum RegistryRoots
Hkey_Classes_Root = &H80000000
Hkey_Current_User = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
Hkey_Users = &H80000003
Hkey_Performance_Data = &H80000004
Hkey_Current_Config = &H80000005
Hkey_Dyn_Data = &H80000006
End Enum

Private Sub Class_Initialize()
KeyPrefix = "Software\ProjectServices\"
Root = HKEY_LOCAL_MACHINE
End Sub

Public Function GetSetting(appname$, section$, key$, Optional DEFAULT)
Dim vValue As Variant
vValue = QueryValue(MakeKey(appname, section), key)
If vValue = "" Then vValue = DEFAULT
GetSetting = vValue
End Function

Public Sub SaveSetting(appname$, section$, key$, setting As Variant, Optional lValueType& = 0)
If lValueType = 0 Then
If IsNumeric(setting) Then
lValueType = REG_DWORD
Else
lValueType = REG_SZ
End If
End If
SetKeyValue MakeKey(appname, section), key, setting, lValueType
End Sub

Public Sub DeleteSetting(appname$, section$, Optional key$)
Dim lRetVal&
Dim hKey&
If Len(key) = 0 Then
lRetVal = RegOpenKeyEx(Root, MakeKey(appname, "&quot, 0, KEY_ALL_ACCESS, hKey)
RegDeleteKey hKey, section
Else
lRetVal = RegOpenKeyEx(Root, MakeKey(appname, section), 0, KEY_ALL_ACCESS, hKey)
RegDeleteValue hKey, key
End If
RegCloseKey (hKey)
End Sub

Public Function QueryValue(sKeyName$, sValueName$) As Variant
Dim lRetVal&
Dim hKey&
Dim vValue As Variant
lRetVal = RegOpenKeyEx(Root, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
RegCloseKey (hKey)
QueryValue = vValue
End Function

Public Function GetAllSettings(appname$, Optional section$) As Variant
Dim lRetVal&
Dim hKey&
Dim lKeys&, lKey&, lKeyLen&, lMaxKeyLen&, sKey$
Dim lClassLen&, sClass$
Dim lValues&, lMaxValueNameLen&, lValueNameLen&
Dim lMaxValueLen&, lValueLen&
Dim lValue&, sValue$, bValue() As Byte
Dim lType&
Dim FTime As FILETIME
Dim vRes() As Variant
hKey = OpenKey(appname, section)
lRetVal = RegQueryInfoKey(hKey, 0&, 0&, 0&, lKeys, lMaxKeyLen, _
lClassLen, lValues, lMaxValueNameLen, lMaxValueLen, 0&, FTime)
If lValues = 0 Then Exit Function
ReDim vRes(lValues - 1, 1)
If lValues Then
lKey = 0
Do
lValueNameLen = lMaxValueNameLen + 1
lValueLen = lMaxValueLen + 1
lType = 0
sKey = Space(lValueNameLen)
lRetVal = RegEnumValueNull(hKey, lKey, 0&, 0&, 0&, lType, 0&, 0&)
If lRetVal = ERROR_NO_MORE_ITEMS Then Exit Do
Select Case lType
Case REG_SZ:
sValue = Space(lValueLen)
lValueNameLen = lMaxValueNameLen + 1
lRetVal = RegEnumValueString(hKey, lKey, sKey, lValueNameLen, 0&, lType, sValue, lValueLen)
vRes(lKey, 0) = Left(sKey, lValueNameLen)
If lRetVal = ERROR_NONE Then
vRes(lKey, 1) = Left$(sValue, lValueLen - 1)
Else
vRes(lKey, 1) = Empty
End If
Case REG_BINARY:
ReDim bValue(lValueLen)
lValueNameLen = lMaxValueNameLen
lValueLen = lMaxValueLen
lRetVal = RegEnumValueBinary(hKey, lKey, sKey, lValueNameLen, 0&, lType, bValue(0), lValueLen)
vRes(lKey, 0) = Left(sKey, lValueNameLen)
If lRetVal = ERROR_NONE Then vRes(lKey, 1) = bValue
Case REG_DWORD:
lValueNameLen = lMaxValueNameLen
lValueLen = lMaxValueLen
lRetVal = RegEnumValueLong(hKey, lKey, sKey, lValueNameLen, 0&, lType, lValue, lValueLen)
vRes(lKey, 0) = Left(sKey, lValueNameLen)
If lRetVal = ERROR_NONE Then vRes(lKey, 1) = lValue
Case Else
Stop
End Select
lKey = lKey + 1
Loop
End If
GetAllSettings = vRes
End Function

Public Function GetAllKeys(appname$, Optional section$) As Variant
Dim lRetVal&
Dim hKey&
Dim lKeys&, lKey&, lKeyLen&, lMaxKeyLen&, sKey$
Dim lClassLen&, sClass$
Dim lValues&, lMaxValueNameLen&, lValueNameLen&
Dim lMaxValueLen&, lValueLen&
Dim lValue&, sValue$
Dim lType&
Dim FTime As FILETIME
Dim vRes() As Variant
hKey = OpenKey(appname, section)
lRetVal = RegQueryInfoKey(hKey, 0&, 0&, 0&, lKeys, lMaxKeyLen, lClassLen, lValues, lMaxValueNameLen, lMaxValueLen, 0&, FTime)
If lKeys = 0 Then Exit Function
ReDim vRes(lKeys - 1, 2)
If lKeys Then
For lKey = 0 To lKeys - 1
sKey = Space(lMaxKeyLen)
lKeyLen = lMaxKeyLen
lRetVal = RegEnumKeyEx(hKey, lKey, sKey, lKeyLen, 0&, sClass, Len(sClass), FTime)
vRes(lKey, 1) = Left(sKey, lKeyLen)
Next
End If
GetAllKeys = vRes
End Function

Public Sub SetKeyValue(sKeyName$, sValueName$, vValueSetting As Variant, lValueType&)
Dim lRetVal&
Dim hKey&
lRetVal = RegCreateKeyEx(Root, sKeyName, 0&, vbNullString, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)
End Sub

Public Sub CreateKey(sKeyName$)
Dim hKey&
Dim lRetVal&
lRetVal = RegCreateKeyEx(Root, sKeyName, 0&, vbNullString, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, lRetVal)
RegCloseKey (hKey)
End Sub

Private Function OpenKey(appname$, section$) As Long
Dim sKey$
Dim hKey&
Dim lRetVal&
sKey = MakeKey(appname, section)
If Len(sKey) = 0 Then
OpenKey = Root
Else
lRetVal = RegOpenKeyEx(Root, sKey, 0, KEY_ALL_ACCESS, hKey)
If lRetVal = ERROR_NONE Then OpenKey = hKey
End If
End Function

Private Function MakeKey(appname$, section$) As String
If Len(section) = 0 And Len(KeyPrefix) = 0 Then
MakeKey = appname
ElseIf Len(section) = 0 Then
MakeKey = KeyPrefix & appname
ElseIf Len(KeyPrefix) = 0 Then
MakeKey = appname & "\" & section
Else
MakeKey = KeyPrefix & appname & "\" & section
End If
End Function

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, _
lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Dim bValue() As Byte
Select Case lType
Case REG_SZ
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, _
lType, sValue, Len(sValue))
Case REG_BINARY
bValue = vValue
SetValueEx = RegSetValueExBinary(hKey, sValueName, 0&, _
lType, bValue(0), LenB(vValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _
lType, lValue, 4)
End Select
End Function

Public Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
Dim bValue() As Byte

On Error GoTo QueryValueExError

' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Exit Function

Select Case lType
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch - 1) 'CRB 12/29/97
Else
vValue = Empty
End If
Case REG_BINARY:
ReDim bValue(cch)
lrc = RegQueryValueExBinary(lhKey, szValueName, 0&, lType, _
bValue(0), cch)
If lrc = ERROR_NONE Then vValue = bValue
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select

QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function

***********************************************************

You can have a form called frmConnection or something similar, which will have three fields Provider, Database, Server

I usually put a test connection button and an ok and cancel button.

Behind the test connection button i have

********************
Dim con As ADODB.Connection
Dim strCon As String
Screen.MousePointer = vbHourglass
On Error Resume Next
Set con = New ADODB.Connection

con.Provider = txtProvider
con.ConnectionString = &quot;Data Source=&quot; & txtServer & &quot;;Initial Catalog=&quot; & txtDatabase & &quot;;Trusted_Connection=Yes;Persist Security Info=True&quot;

con.Open
Screen.MousePointer = vbNormal
If err = 0 Then
MsgBox &quot;Connection Successfull&quot;
Else
MsgBox &quot;Connection Failed - &quot; & err.Number & &quot; &quot; & err.Description
End If

Set con = Nothing
********************

NOTE this is for a SQL 2000 db, you will have to alter your connection details for an access db

The cancel button just cancels and the ok button does this


********************
Dim reg As CRegAPI


Set reg = New CRegAPI

reg.SaveSetting &quot;AppName&quot;, &quot;&quot;, &quot;Provider&quot;, txtProvider
reg.SaveSetting &quot;AppName&quot;, &quot;&quot;, &quot;Initial Catalog&quot;, txtDatabase
reg.SaveSetting &quot;AppName&quot;, &quot;&quot;, &quot;Data Source&quot;, txtServer

Set reg = Nothing
Me.Hide
blnOK = True

If objdata.Connect = 0 Then
frmMain.Show
Else
ExitApp
End If

**********************************

Now like i said this works for me, if anyone out there can see that i'm doing something severely wrong feel free to point it out

Transcend

 

[Transcend]

Note also:

If objdata.Connect = 0 Then
frmMain.Show
Else
ExitApp
End If


this part uses my own db connection code, you'll have to replace it with your own

Transcend

 

[Transcend]

And to get settings back out of the reg ...

Dim reg As CRegAPI
Dim strProvider As String
Dim StrCat As String
Dim strDS As String

' Get Registry Settings
Set reg = New CRegAPI
strProvider = reg.GetSetting(&quot;AppName&quot;, &quot;&quot;, &quot;Provider&quot;, &quot;&quot
StrCat = reg.GetSetting(&quot;AppName&quot;, &quot;&quot;, &quot;Initial Catalog&quot;, &quot;&quot
strDS = reg.GetSetting(&quot;AppName&quot;, &quot;&quot;, &quot;Data Source&quot;, &quot;&quot
Set reg = Nothing

Transcend
[goregous]

 

[johnwm]

You could always use the intrinsic SaveSetting and GetSetting if you don't need to bury the registry entries...
________________________________________________________________
If you want to get the best response to a question, please check out FAQ222-2244 first

'People who live in windowed environments shouldn't cast pointers.'

 

[Transcend]

mrf3000 ... ?

 

[mrf3000]

Thanks for the info guys....Transcend-Is all that code necssary considering teh savesetting and getsetting commands? The only question I have is how do you make sure it goes into HKeyLocalMachine instead of HKeyCurrentUser or will the getsetting and save setting commands just find the registry entry?

Thanks,
mrf3000

 

[Transcend]

When I use this code the registry settings get saved to HKEY_LOCAL_MACHINE

Transcend