怎样来读取“dsn”中的用户建立的数据源。

[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI]

操作注册表全函数
Option Explicit
'String
  Global Const REG_SZ As Long = 1
'Dword
  Global Const REG_DWORD As Long = 4
'Binary
  Global Const REG_BINARY As Long = 3

  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_SUCCESS = 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 RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult 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 RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  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
  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 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
  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
  Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpValueName As String) As Long
  Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
  Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long

  Global Const MyAppKey = "SoftWare\ScriptServer\" '本软件所在注册表的主键
  Global Const AppKey = "SoftWare\ScriptServer\1.0\" '应用程序所在注册表的主键
  Global Const UserKey = "SoftWare\ScriptServer\Users\" '用户信息所在注册表的主键
  Public Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
'Usage:    CreateNewKey "KeyName\SubKey\SubSubKey", HKEY_CURRENT_USER
    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)
    If lRetVal <> 0 Then Exit Sub
End SubPublic Sub DeleteValue(sKeyName As String, sValueName As String, lPredefinedKey As Long)
'Usage: DeleteKey "Test1\Test2\Test3","ValueName",HKEY_CURRENT_USER
    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)
    If lRetVal <> 0 Then Exit Sub
End SubPublic Sub DeleteKey(sKeyName As String, sDelKeyName As String, lPredefinedKey As Long)
'Usage: DeleteKey "Test1\Test2","Test3",HKEY_CURRENT_USER
    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(hkey, sDelKeyName)
    RegCloseKey (hkey)
    If lRetVal <> 0 Then Exit Sub
End SubPublic Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long, lPredefinedKey As Long)
'Usage: SetKeyValue "TestKey\SubKey1", "StringValue", "Hello", REG_SZ, HKEY_CURRENT_USER
'NOTE: Binary values are reversed in registry: 95 00 00 00 in the registry must be entered as 00 00 00 95
    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)
    If lRetVal <> 0 Then Exit Sub
End SubPrivate Function SetValueEx(ByVal hkey As Long, sValueName As String, lType As Long, ByVal vValue As Variant) As Long
    'Called by SetKeyValue
    Dim lValue As Long
    Dim sValue As String
    Select Case lType
        Case REG_SZ
            sValue = vValue & Chr$(0)
            SetValueEx = RegSetValueExString(hkey, sValueName, 0&, lType, sValue, Len(sValue) * 2)
        Case REG_DWORD, REG_BINARY
            lValue = vValue
            SetValueEx = RegSetValueExLong(hkey, sValueName, 0&, lType, lValue, 4)
        End Select
End FunctionPrivate Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    'Called By Query Value
    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, REG_BINARY:
            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 SelectQueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End FunctionPublic Function QueryValue(sKeyName As String, sValueName As String, lPredefinedKey As Long) As Variant
'Usage:  QueryValue "TestKey\SubKey1", "StringValue",HKEY_CURRENT_USER
    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)
    If lRetVal <> 0 Then Exit Function
End Function'写注册表
Public Function WriteReg(ActionType As String, KeyName As String, ByVal KeyValue As String) As Long
On Error GoTo Err
    Dim hkey As Long
    RegOpenKeyEx HKEY_CURRENT_USER, ActionType, 0, KEY_ALL_ACCESS, hkey
    'RegCreateKey HKEY_CURRENT_USER, ActionType, hkey
    RegSetValueEx hkey, KeyName, 0, REG_SZ, ByVal KeyValue, Len(KeyValue) + 1
    RegCloseKey hkey
    WriteReg = 1
    Exit Function
Err:
    WriteReg = 0
End Function'读注册表
Public Function ReadReg(ActionType As String, KeyName As String) As String
On Error GoTo Err
    Dim hkey As Long, lenData As Long, typeData As Long
    Dim sS As String
    RegOpenKeyEx HKEY_CURRENT_USER, ActionType, 0, KEY_ALL_ACCESS, hkey
    'RegCreateKey HKEY_CURRENT_USER, ActionType, hkey
    RegQueryValueEx hkey, KeyName, 0, typeData, ByVal vbNullString, lenData
    sS = String(lenData, Chr(0))
    RegQueryValueEx hkey, KeyName, 0, typeData, ByVal sS, lenData '注意ByVal千万别忘了
    sS = Left(sS, InStr(sS, Chr(0)) - 1)
    RegCloseKey hkey
    ReadReg = sS
    Exit Function
Err:
    ReadReg = ""
End Function

'引用 ODBC Driver & Data Source Name Functions
Dim x As New ODBCTool.Dsn
Dim i As Long
Dim a() As String
If x.GetDataSourceList(a) Then
   For i = LBound(a) To UBound(a)
       Debug.Print a(i) & ""
   Next i
End If
If x.GetOdbcDriverList(a) Then
   For i = LBound(a) To UBound(a)
       Debug.Print a(i) & ""
   Next i
End If

'你添加一个　"ODBC 登录" 窗体:
Option Explicit
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&)
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1
Private Sub cmdCancel_Click()
    Unload Me
End SubPrivate Sub cmdOK_Click()
    Dim sConnect    As String
    Dim sADOConnect As String
    Dim sDAOConnect As String
    Dim sDSN        As String

    If cboDSNList.ListIndex > 0 Then
        sDSN = "DSN=" & cboDSNList.Text & ";"
    Else
        sConnect = sConnect & "Driver=" & cboDrivers.Text & ";"
        sConnect = sConnect & "Server=" & txtServer.Text & ";"
    End If

    sConnect = sConnect & "UID=" & txtUID.Text & ";"
    sConnect = sConnect & "PWD=" & txtPWD.Text & ";"

    If Len(txtDatabase.Text) > 0 Then
        sConnect = sConnect & "Database=" & txtDatabase.Text & ";"
    End If

    sADOConnect = "PROVIDER=MSDASQL;" & sDSN & sConnect
    sDAOConnect = "ODBC;" & sDSN & sConnect

    MsgBox _
    "要打开一个ADO 连接，使用： " & vbCrLf & _
    "Set gConnection = New Connection" & vbCrLf & _
    "gConnection.Open """ & sADOConnect & """" & vbCrLf & vbCrLf & _
    "要打开一个DAO 数据库对象，使用： " & vbCrLf & _
    "设置 gDatabase = OpenDatabase(vbNullString, 0, 0, sDAOConnect)" & vbCrLf & vbCrLf & _
    "或打开一个 RDO 连接, 使用:" & vbCrLf & _
    "设置 gRDOConnection = rdoEnvironments(0).OpenConnection(sDSN, rdDriverNoPrompt, 0, sConnect)"

    '设置 gDatabase = OpenDatabase(vbNullString, 0, 0, sDAOConnect)
    'RDO:
    '设置 gRDOConnection = rdoEnvironments(0).OpenConnection(sDSN, rdDriverNoPrompt, 0, sConnect)
End SubPrivate Sub Form_Load()
    GetDSNsAndDrivers
End SubPrivate Sub cboDSNList_Click()
    On Error Resume Next
    If cboDSNList.Text = "(None)" Then
        txtServer.Enabled = True
        cboDrivers.Enabled = True
    Else
        txtServer.Enabled = False
        cboDrivers.Enabled = False
    End If
End SubSub GetDSNsAndDrivers()
    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         '环境句柄    On Error Resume Next
    cboDSNList.AddItem "(None)"    '获得 DSNs
    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 = Left$(sDSNItem, iDSNLen)
            sDRV = Left$(sDRVItem, iDRVLen)

            If sDSN <> Space(iDSNLen) Then
                cboDSNList.AddItem sDSN
                cboDrivers.AddItem sDRV
            End If
        Loop
    End If
    '删除重复项
    If cboDSNList.ListCount > 0 Then
        With cboDrivers
            If .ListCount > 1 Then
                i = 0
                While i < .ListCount
                    If .List(i) = .List(i + 1) Then
                        .RemoveItem (i)
                    Else
                        i = i + 1
                    End If
                Wend
            End If
        End With
    End If
    cboDSNList.ListIndex = 0
End Sub

工程—>更多的ACTIVEX设计器—>DataEnvironment
Connection1——>属性—>Microsoft ole provider for odbc Drivers—>使用数据源名称中选dsn
程序中：dateenvironment.connection.open

调试易

怎样来读取“dsn”中的用户建立的数据源。

解决方案 »