Link to home
Start Free TrialLog in
Avatar of Ora_Techie
Ora_Techie

asked on

Create SYSTEM DSN Programatically if Exist then Overwrite the Existing Path

Hi Experts

I want to Create a SYSTEM DSN at  RunTime
This would be in Sub Main or suggest me some better way

i want to take the Database path at runtime through
App.Path & "\" & "\Database\MyDb.Mdb"

Now i want a Function to Check and create DSN like this

NewDSNName = Abc
NewDSNPath = App.Path & Database

If NewDSNName = Any Existing Odbc DSN Name then
     IF NewDSNPath = Current odbc DSN Path then
          exit function
     else
          Over Write Same Available DSN Path = NewDSNPath
     endif
else
     Create a Fresh New DSN
endif

Please provide solution for both Acces & Sql server
ASKER CERTIFIED SOLUTION
Avatar of Ryan Chong
Ryan Chong
Flag of Singapore image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Ora_Techie
Ora_Techie

ASKER

thank You
i have already tried these solutions BUT

Please Read the Question Carefully

i want to overwrite the path
what if Source folder is moved to another location and when the application runs again then DSN is there but path is not valid. i want to check and confirm that path each time.

so Please reply accordingly
You may need to integrate the above code with the Registry APIs, which allow you to read and write into Registry. Just wait couple of minutes, i will do a mock example for you..

cheers ;-)
Try this example, which customize from above example:

Option Explicit

Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
   (ByVal hwndParent As Long, ByVal fRequest As Long, _
   ByVal lpszDriver As String, ByVal lpszAttributes As String) _
   As Long

Private Const ODBC_ADD_SYS_DSN = 4

Public Function CreateSQLServerDSN(DSNName As String, _
   ServerName As String, Database As String) As Boolean

'PURPOSE: 'CREATES A SYSTEM DSN FOR AN SQL SERVER DATABASE
'PARAMETERS: 'DSNName = DSN Name
             'ServerName = Name of Server
             'Database = Database to Use
'RETURNS: True if successful, false otherwise
'EXAMPLE: CreateSQLServerDSN "MyDSN", "MyServer", "MyDatabase"

Dim sAttributes As String

sAttributes = "DSN=" & DSNName & Chr(0)
sAttributes = sAttributes & "Server=" & ServerName & Chr(0)
sAttributes = sAttributes & "Database=" & Database & Chr(0)
CreateSQLServerDSN = CreateDSN("SQL Server", sAttributes)

End Function

Public Function CreateAccessDSN(DSNName As String, _
  DatabaseFullPath As String) As Boolean

'PURPOSE: 'CREATES A SYSTEM DSN FOR AN ACCESS DATABASE
'PARAMETERS: 'DSNName = DSN Name
             'DatabaseFullPath = Full Path to .mdb file
'RETURNS: True if successful, false otherwise
'EXAMPLE: CreateAccessDSN "MyDSN", "C:\MyDb.mdb"

    Dim sAttributes As String
   
    'TEST TO SEE IF FILE EXISTS: YOU CAN REMOVE IF YOU
    'DON'T WANT IT
    If dir(DatabaseFullPath) = "" Then Exit Function
   
sAttributes = "DSN=" & DSNName & Chr(0)
sAttributes = sAttributes & "DBQ=" & DatabaseFullPath & Chr(0)
CreateAccessDSN = CreateDSN("Microsoft Access Driver (*.mdb)", _
   sAttributes)

End Function

Public Function CreateDSN(Driver As String, Attributes As _
  String) As Boolean

'PURPOSE: CREATES A SYSTEM DSN
'PARAMETERS: 'Driver = DriverName
'ATTRIBUTES: 'Attributes; varies as a function
             'of the Driver
'EXAMPLE: Refer to Code Above

    CreateDSN = SQLConfigDataSource(0&, ODBC_ADD_SYS_DSN, _
      Driver, Attributes)
       
End Function

Public Function isFileExist(filePath As String) As Boolean
    On Error GoTo EH
    If filePath <> "" And dir$(filePath) <> "" Then
        isFileExist = True
    Else
        isFileExist = False
    End If
    Exit Function
EH:
    isFileExist = False
End Function

Private Sub Form_Load()
    Dim regDSNPath As String
    Dim myDBPath As String
    Dim DSNName As String
   
    DSNName = "abc"
    myDBPath = Replace$(App.path & "\Database\MyDb.Mdb", "\\", "\")
   
    If isFileExist(myDBPath) = False Then
        MsgBox "Database Not Found!"
        Exit Sub
    End If
   
    regDSNPath = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DSNName, "DBQ")
    If regDSNPath = "" Then
        CreateAccessDSN DSNName, myDBPath
        MsgBox "DSN Created!"
    ElseIf isFileExist(regDSNPath) = False Then
        CreateAccessDSN DSNName, myDBPath
        MsgBox "DSN Updated!"
    Else
        MsgBox "DSN is ok, db path is correct"
    End If
End Sub

also add this Registry Module by adding it into a New Module:

Option Explicit

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const REG_OPTION_NON_VOLATILE = 0

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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
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 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
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
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
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
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
Public Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Public Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)

Public Result As Long

Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)
' Description:
'   This Function will Delete a key
'
' Syntax:
'   DeleteKey Location, KeyName
'
'   Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'   , HKEY_USERS
'
'   KeyName is name of the key you wish to delete, it may include subkeys (example "Key1\SubKey1")


    Dim lRetVal As Long         'result of the SetValueEx function
    Dim hKey As Long         'handle of open key
   
    'open the specified key
   
    'lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
    lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)
    'RegCloseKey (hKey)
End Function

Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
'   This Function will delete a value
'
' Syntax:
'   DeleteValue Location, KeyName, ValueName
'
'   Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'   , HKEY_USERS
'
'   KeyName is the name of the key that the value you wish to delete is in
'   , it may include subkeys (example "Key1\SubKey1")
'
'   ValueName is the name of value you wish to delete

       Dim lRetVal As Long         'result of the SetValueEx function
       Dim hKey As Long         'handle of open key

       'open the specified key

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = RegDeleteValue(hKey, sValueName)
       RegCloseKey (hKey)
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

    Select Case lType
        Case REG_SZ
            sValue = vValue
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
        End Select

End Function

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

    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 Error 5

    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If

        ' For DWORDS
        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

Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
' Description:
'   This Function will create a new key
'
' Syntax:
'   QueryValue Location, KeyName
'
'   Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'   , HKEY_USERS
'
'   KeyName is name of the key you wish to create, it may include subkeys (example "Key1\SubKey1")
   
    Dim hNewKey As Long         'handle to the new key
    Dim lRetVal As Long         'result of the RegCreateKeyEx function
   
    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Function

Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
' Description:
'   This Function will set the data field of a value
'
' Syntax:
'   QueryValue Location, KeyName, ValueName, ValueSetting, ValueType
'
'   Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'   , HKEY_USERS
'
'   KeyName is the key that the value is under (example: "Key1\SubKey1")
'
'   ValueName is the name of the value you want create, or set the value of (example: "ValueTest")
'
'   ValueSetting is what you want the value to equal
'
'   ValueType must equal either REG_SZ (a string) Or REG_DWORD (an integer)

       Dim lRetVal As Long         'result of the SetValueEx function
       Dim hKey As Long         'handle of open key

       'open the specified key
   
       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)

End Function

Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
'   This Function will return the data field of a value
'
' Syntax:
'   Variable = QueryValue(Location, KeyName, ValueName)
'
'   Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'   , HKEY_USERS
'
'   KeyName is the key that the value is under (example: "Software\Microsoft\Windows\CurrentVersion\Explorer")
'
'   ValueName is the name of the value you want to access (example: "link")

       Dim lRetVal As Long         'result of the API functions
       Dim hKey As Long         'handle of opened key
       Dim vValue As Variant      'setting of queried value

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       QueryValue = vValue
       RegCloseKey (hKey)
End Function
Good

its working
BUT Sorry  ........  i  just  checked  again the following

http://www.freevbcode.com/ShowCode.Asp?ID=502

its also working perfectly to overwirte
so no  need for adding more complexity ... i am writing this for future readers

anyhow thanx ... A little more is ...

my Access Db is password protected BUT now i am facing problem in opening connection with this database. when i test the connection it shows invalid username password are path BUT i am actually gave proper path ????

Could U provide me the string for a password protected DB. with jet ole db 4

waiting
>>Could U provide me the string for a password protected DB. with jet ole db 4
Take a look at:
http://www.able-consulting.com/ADO_Conn.htm
http://www.connectionstrings.com

Frankly, i'm very not satified with the grade "C", any reason why will be good.
Oh sorry ! That was my mistake...i wanted to give you a grace B....really sorry abt that.

i will take look to above URLs and will give you more points..


and sorry again
Hi riazpk,

Try to do this:

Post a 0 pts question at Community Support (https://www.experts-exchange.com/Community_Support/) and request for a change grade.

If you dont know how to do it, just let me know.

cheers