怎样在程序中创建ODBC数据库源？

Question

自己看看吧,有点麻烦，不知道有没有好的办法。
Option Explicit
 
 Private Const READ_CONTROL = &H20000
 Private Const SYNCHRONIZE = &H100000
 Private Const STANDARD_RIGHTS_ALL = &H1F0000
 Private Const STANDARD_RIGHTS_EXECUTE = &H20000
 Private Const STANDARD_RIGHTS_READ = &H20000
 Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
 Private Const STANDARD_RIGHTS_WRITE = &H20000
 Private Const KEY_CREATE_LINK = &H20
 Private Const KEY_CREATE_SUB_KEY = &H4
 Private Const KEY_ENUMERATE_SUB_KEYS = &H8
 Private Const KEY_EVENT = &H1         '  Event contains key event record
 Private Const KEY_NOTIFY = &H10
 Private Const KEY_QUERY_VALUE = &H1
 Private Const KEY_SET_VALUE = &H2
 Private Const KEYEVENTF_EXTENDEDKEY = &H1
 Private Const KEYEVENTF_KEYUP = &H2
 Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
 Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
 Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
 Private Const KEY_EXECUTE = (KEY_READ)'Error private CONST  ants
 Private Const ERROR_BADDB = 1009&
 Private Const ERROR_BADKEY = 1010&
 Private Const ERROR_CANTOPEN = 1011&
 Private Const ERROR_CANTREAD = 1012&
 Private Const ERROR_CANTWRITE = 1013&
 Private Const ERROR_ACCESS_DENIED = 5&
 Private Const ERROR_SUCCESS = 0&
 Private Const ERROR_OUTOFMEMORY = 14&
 Private Const ERROR_INVALID_PARAMETER = 87     '  dderror'Registry value type private CONST  ants
 Private Const REG_BINARY = 3                         ' Free form binary
 Private Const REG_CREATED_NEW_KEY = &H1              ' New Registry Key created
 Private Const REG_DWORD = 4                          ' 32-bit number
 Private Const REG_DWORD_BIG_ENDIAN = 5               ' 32-bit number
 Private Const REG_DWORD_LITTLE_ENDIAN = 4            ' 32-bit number (same as REG_DWORD)
 Private Const REG_EXPAND_SZ = 2                      ' Unicode nul terminated string
 Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9       ' Resource list in the hardware description
 Private Const REG_LINK = 6                           ' Symbolic Link (unicode)
 Private Const REG_MULTI_SZ = 7                       ' Multiple Unicode strings
 Private Const REG_SZ = 1                             ' Unicode nul terminated string
 Private Const REG_NONE = 0                           ' No value type'Root  private CONST
 Private Const HKEY_CLASSES_ROOT = &H80000000
 Private Const HKEY_CURRENT_CONFIG = &H80000005
 Private Const HKEY_CURRENT_USER = &H80000001
 Private Const HKEY_DYN_DATA = &H80000006
 Private Const HKEY_LOCAL_MACHINE = &H80000002
 Private Const HKEY_PERFORMANCE_DATA = &H80000004
 Private Const HKEY_USERS = &H80000003'Type
Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
'Api声明
 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 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           ' Note that if you private decalare  the lpData parameter as String, you must pass it By Value.
 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition 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           ' Note that if you private decalare  the lpData parameter as String, you must pass it By Value.
 Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData 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 GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'获取系统DSN
 Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv&, ByVal fDirection%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal szDescription$, ByVal cbDescriptionMax%, pcbDescription%) As Integer
 Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
 Private Const SQL_SUCCESS As Long = 0
 Private Const SQL_FETCH_NEXT As Long = 1

Answer 1

Dim sCreatKey As String
Dim lReturn As Long  '记录返回的句柄
Dim i As Long
Dim lKey As Long
Dim sKey As String
Dim strBuf As String
Dim sWindowsDir As String
sWindowsDir = ""
strBuf = Space$(30)
Call GetWindowsDirectory(strBuf, 30)
strBuf = Trim(strBuf)
   For i = 1 To Len(strBuf)
      If Asc(Mid(strBuf, i, 1)) <> 23 And Asc(Mid(strBuf, i, 1)) <> 0 Then
        sWindowsDir = sWindowsDir & Mid(strBuf, i, 1)
      End If
   Next
'写“ODBC Data Sources“主键
sCreatKey = "Software\" & _
          "ODBC\" & _
          "ODBC.INI\" & _
          "ODBC Data Sources"
Call RegCreateKey(HKEY_LOCAL_MACHINE, sCreatKey, REG_EXPAND_SZ)
sKey = "Canyin"
sCreatKey = "Software\" & _
          "ODBC\" & _
          "ODBC.INI\" & _
          sKey
'写主键
Call RegCreateKey(HKEY_LOCAL_MACHINE, sCreatKey, REG_EXPAND_SZ)
Call RegOpenKeyEx(HKEY_LOCAL_MACHINE, sCreatKey, REG_SZ, 0&, lReturn)
'Canyin项值
sKey = Trim$(App.Path & "\MarbleCanyin.mdb")
Call RegSetValueEx(lReturn, "DBQ", 0&, REG_SZ, ByVal sKey, Len(sKey))
sKey = Trim$(sWindowsDir & "\SYSTEM\odbcjt32.dll")
Call RegSetValueEx(lReturn, "Driver", 0&, REG_EXPAND_SZ, ByVal sKey, Len(sKey))
lKey = 25
Call RegSetValueEx(lReturn, "DriverId", 0&, REG_DWORD, lKey, 4)
sKey = Trim$("MS Access;")
Call RegSetValueEx(lReturn, "FIL", 0&, REG_SZ, ByVal sKey, Len(sKey))
sKey = Trim$("marblemhw")
Call RegSetValueEx(lReturn, "PWD", 0&, REG_SZ, ByVal sKey, Len(sKey))
lKey = 0
Call RegSetValueEx(lReturn, "SafeTransactions", 0&, REG_DWORD, lKey, 4)
sKey = Trim$("admin")
Call RegSetValueEx(lReturn, "UID", 0&, REG_EXPAND_SZ, ByVal sKey, Len(sKey))
Call RegCloseKey(lReturn)sCreatKey = sCreatKey & "\Engines"
Call RegCreateKey(HKEY_LOCAL_MACHINE, sCreatKey, REG_EXPAND_SZ)
sCreatKey = sCreatKey & "\Jet"
Call RegCreateKey(HKEY_LOCAL_MACHINE, sCreatKey, REG_EXPAND_SZ)
Call RegOpenKeyEx(HKEY_LOCAL_MACHINE, sCreatKey, REG_SZ, 0&, lReturn)
'Jet的项值
sKey = Trim$("Yes")
Call RegSetValueEx(lReturn, "ImplicitCommitSync", 0&, REG_SZ, ByVal sKey, Len(sKey))
lKey = 4096
Call RegSetValueEx(lReturn, "MaxBufferSize", 0&, REG_DWORD, lKey, 4)
lKey = 5
Call RegSetValueEx(lReturn, "PageTimeout", 0&, REG_DWORD, lKey, 4)
lKey = 3
Call RegSetValueEx(lReturn, "Threads", 0&, REG_DWORD, lKey, 4)
sKey = Trim$("Yes")
Call RegSetValueEx(lReturn, "UserCommitSync", 0&, REG_SZ, ByVal sKey, Len(sKey))
Call RegCloseKey(lReturn)
sKey = "Microsoft Access Driver (*.mdb)"
sCreatKey = "Software\" & _
          "ODBC\" & _
          "ODBC.INI\ODBC Data Sources"
Call RegOpenKeyEx(HKEY_LOCAL_MACHINE, sCreatKey, REG_SZ, 0&, lReturn)
Call RegSetValueEx(lReturn, "Canyin", 0&, REG_SZ, ByVal sKey, Len(sKey))
Call RegCloseKey(lReturn)
MsgBox "修改了部分系统信息，请重新运行程序！", vbInformation, "提示"
End
End Sub

Answer 2

Public Function funGetDsn(sDsnName As String) As Boolean  '获取系统DSN
  On Error Resume Next
  funGetDsn = False
  Dim i As Integer
  Dim sDSNItem As String * 1024
  Dim sDRVItem As String * 1024
  Dim sDSN As String
  Dim sDRV As String
  Dim iDSNLen As Integer
  Dim iDRVLen As Integer
  Dim lHenv As Long     '对环境处理  '获取 DSN
  If SQLAllocEnv(lHenv) <> -1 Then
    Do Until i <> SQL_SUCCESS
      sDSNItem = Space(1024)
      sDRVItem = Space(1024)
      i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
      sDSN = VBA.Left(sDSNItem, iDSNLen)
      sDRV = VBA.Left(sDRVItem, iDRVLen)
        
      If sDSN <> Space(iDSNLen) Then
        'cboDSNList.AddItem sDSN
        'cboDrivers.AddItem sDRV
        If sDSN = sDsnName Then
          funGetDsn = True
          Exit Do
        End If
      End If
    Loop
  End If
End Function

Answer 3

这个简单，不过需要一个RDO：Private Function RegisterDB(ByVal strDBName As String, ByVal strSource As String) As Boolean   Dim strAttri As String
   
   RegisterDB = False
   
   On Error GoTo EroHandle
   
   strAttri = "DESCRIPTION=" & _
      "SQL Server on server CYZ" & Chr$(13) & _
      "OEMTOANSI=NO" & Chr$(13) & _
      "SERVER=" & strSQLServer & Chr$(13) & _
      "Database=" & strDBName
'      & Chr$(13) & "Address=\\SEQUEL\PIPE\SQL\QUERY"
   rdoEngine.rdoRegisterDataSource strSource, "SQL Server", True, strAttri
   RegisterDB = True
   
   Exit Function
   
EroHandle:
   MsgBox "无法注册ODBC(32位)数据源：" & strSource & "！", vbInformation, "数据库向导"
   
End Function另外可直接用注册表API实现。

Answer 4

工程-》引用 “ODBC Driver & Data Source Name Functions”Private Sub Form_Load()
    Dim a As New ODBCTool.Dsn
    ......
    ......'your code
    a.CreateDSN dsnname, odbcdriver, svrname, dbname, user, pwd, dsndesc, silent, odbcattr
    
End Sub

Answer 5

cooL
 i like it！