vb建立数据源问题

[tangxiaosan001]

我现在要做个动态建立数据源？也就是刚开始的时候没有这个ww数据源，就出现建立数据源对话框，如何有这个数据源，则不出现这个对话框（sql server，a 数据库，服务器为cp1），请各位大虾指点指点，小弟谢谢先了。

[supergreenbean]

http://community.csdn.net/Expert/topic/3372/3372772.xml?temp=.2449762

[suxylin]

做个配置文件
应该就没有问题了
我有例子，发邮件给我！
[e-mail]

[aohan]

'************************************************
' This Program is Designed To Create a System DSN
' Using Access Database (Microsoft Jet Engine)
' To Run this Program effectively You should have
' Microsoft Access Driver (*.mdb) installed on your
' Machine
' ***********************************************

Option Explicit
Private Const REG_SZ = 1 'Constant for a string variable type.
Private Const REG_BINARY = 3 'Constant for Binary
Private Const REG_DWORD = 4 '32-bit number

Private Const HKEY_LOCAL_MACHINE = &H80000002

'Creates a Key In Registry
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'API FOR STRING
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
'API FOR DWORD
Private Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
'API FOR BINARY
Private Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
'API for closing the Registry Key
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Sub cmdDSN_Click()

Dim DataSourceName As String
Dim DatabaseName As String
Dim Description As String
Dim DriverPath As String
Dim DriverName As String
Dim LastUser As String
Dim Regional As String
Dim Server As String

Dim lResult As Long
Dim hKeyHandle As Long

Dim Engines As String
Dim Jet As String

Dim DBQPath As String
Dim Driver As String
Dim DriverId As Long
Dim FIL As String
Dim SafeTransaction As Long
Dim UID As String

Dim ImplicitCommitSync As String
Dim MaxBufferSize As Long
Dim PageTimeOut As Long
Dim Threads As Long
Dim UserCommitSync As String
Dim Password As String


DataSourceName = Text1.Text
Engines = "Engines"
Jet = "Jet"
DBQPath = Text2.Text
Driver = "C:\WinNT\system32\odbcjt32.dll"
UID = Text3.Text
FIL = "MS Access;"
DriverId = &H19
SafeTransaction = &H0
ImplicitCommitSync = ""
MaxBufferSize = &H800
PageTimeOut = &H5
Threads = &H3
UserCommitSync = ""
Password = Text4.Text

'Specify the DSN parameters.

On Error GoTo ErrorHandler

'If You are using Windows NT use the folllowing Drivers
Driver = "C:\WinNT\system32\odbcjt32.dll"

'If You are using Windows 95,98 uncomment the following line and comment the above line
'Driver = "C:\Windows\system\odbcjt32.dll"



'Create the new DSN key.
lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & _
DataSourceName, hKeyHandle)

'DBQ
lResult = RegSetValueEx(hKeyHandle, "DBQ", 0&, REG_SZ, _
ByVal DBQPath, Len(DBQPath))

'Driver
lResult = RegSetValueEx(hKeyHandle, "Driver", 0&, REG_SZ, _
ByVal Driver, Len(Driver))

lResult = RegSetValueExA(hKeyHandle, "DriverId", 0, REG_DWORD, DriverId, 4) 'write the value

'FIL
lResult = RegSetValueEx(hKeyHandle, "FIL", 0&, REG_SZ, _
ByVal FIL, Len(FIL))

lResult = RegSetValueExA(hKeyHandle, "SafeTransaction", 0, REG_DWORD, SafeTransaction, 4) 'write the value

'Password
lResult = RegSetValueEx(hKeyHandle, "PWD", 0&, REG_SZ, _
ByVal Password, Len(Password))

'UID
lResult = RegSetValueEx(hKeyHandle, "UID", 0&, REG_SZ, _
ByVal UID, Len(UID))


lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DataSourceName & "\" & _
Engines, hKeyHandle)

lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DataSourceName & "\" & Engines & "\" & _
Jet, hKeyHandle)

'ImplicitCommitsync
lResult = RegSetValueEx(hKeyHandle, "ImplicitCommitSync", 0&, REG_SZ, _
ByVal ImplicitCommitSync, Len(ImplicitCommitSync))
'MaxBufferSize
lResult = RegSetValueExA(hKeyHandle, "MaxBufferSize", 0, REG_DWORD, MaxBufferSize, 4) 'write the value
'PageTimeOut
lResult = RegSetValueExA(hKeyHandle, "PageTimeOut", 0, REG_DWORD, PageTimeOut, 4) 'write the value
'Threads
lResult = RegSetValueExA(hKeyHandle, "Threads", 0, REG_DWORD, Threads, 4) 'write the value
'UserCommitSync
lResult = RegSetValueEx(hKeyHandle, "UserCommitSync", 0&, REG_SZ, _
ByVal UserCommitSync, Len(UserCommitSync))

'Close the new DSN key.
lResult = RegCloseKey(hKeyHandle)

'Open ODBC Data Sources key to list the new DSN in the ODBC Manager.
'Specify the new value.
'Close the key.

lResult = RegCreateKey(HKEY_LOCAL_MACHINE, _
"SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKeyHandle)
lResult = RegSetValueEx(hKeyHandle, DataSourceName, 0&, REG_SZ, _
ByVal DriverName, Len(DriverName))
lResult = RegCloseKey(hKeyHandle)
MsgBox "DSN Creation Successfull !", vbExclamation
Exit Sub

ErrorHandler:
MsgBox "Error In Creating DSN"
Exit Sub
End Sub

Private Sub Form_Load()

End Sub

[jam021]

关注,帮你顶!

[suxylin]

这是写配置文件的程序：
Public Declare Function GetPrivateProfileString Lib "kernel32" _
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
Public Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName _
As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long

Sub GetDs(Dr As String, Ds As String, UserName As String, PassWord As String)
Dim temp As String * 50, t1 As String, k As Integer, i As Integer
If (Len(Dir(App.Path & "\yourini.ini")) = 0) Then
MsgBox "找不到yourini.ini 文件，请重新配置！！"
End
End If

GetPrivateProfileString "dc", "datasource", "", temp, 50, App.Path & "\yourini.ini"
Dr = LTrim$(Mid$(temp, 1, InStr(1, temp, Chr$(0)) - 1))

GetPrivateProfileString "dc", "database", "", temp, 50, App.Path & "\yourini.ini"
Ds = LTrim$(Mid$(temp, 1, InStr(1, temp, Chr$(0)) - 1))

GetPrivateProfileString "dc", "username", "", temp, 50, App.Path & "\yourini.ini"
UserName = LTrim$(Mid$(temp, 1, InStr(1, temp, Chr$(0)) - 1))

GetPrivateProfileString "dc", "password", "", temp, 50, App.Path & "\yourini.ini"
PassWord = LTrim$(Mid$(temp, 1, InStr(1, temp, Chr$(0)) - 1))
End Sub

调用API来写INI文件，然后获得INI的信息

[suxylin]

这是连接数据库的程序：
Sub OpenDb(Conn As ADODB.Connection)
Dim Dr As String, Ds As String, UserName As String, PassWord As String
On Error GoTo aa:
GetDs Dr, Ds, UserName, PassWord

If Len(Dr) = 0 Then
TestConnSql.Show 1 ‘这里是做一个查找SQL服务器的窗体，用来查找可用的SQL服务器
Exit Sub
End If

Conn.ConnectionString = "provider=sqloledb.1;data source=" _
& Dr & ";initial catalog=" & Ds & ";uid=" & UserName & ";pwd=" & PassWord
Conn.Open
Exit Sub

aa:
MsgBox "无法连接到SQL Server数据库服务器，请联系数据库管理员！！"
TestConnSql.Show 1
End Sub
Sub OpenRs(Conn As ADODB.Connection, rs As ADODB.Recordset, Ss As String)
' ss=SQL语句
On Error GoTo a:
rs.CursorLocation = adUseClient
rs.Open Ss, Conn, adOpenForwardOnly, adLockPessimistic
Exit Sub

a:
MsgBox "无法打开指定的表，请联系数据库管理员！"
End Sub

[suxylin]

有什么问题个可以跟我联系，顺便给你一个配置文件的书写格式：
[dc]
datasource=服务器名
database=数据库名
username=sa
password=

[tangxiaosan001]

谢谢各位大虾了，那么怎么样判断我的数据源在服务器上有了呢？建立数据源理解，如何判断我就不清楚了，大虾指点一二,谢先！

[haohaohappy]

帮忙

[leolan]

Option Explicit

Private Declare Function SQLConfigDataSource Lib "odbccp32.dll" (ByVal hwndParent As Long, ByVal fRequest As Integer, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long

Private Const ODBC_ADD_DSN As Long = 1
Private Const ODBC_CONFIG_DSN As Long = 2
Private Const ODBC_REMOVE_DSN As Long = 3

Public Function CreateDSN(ByVal sDSN As String) As Boolean
Dim sDriver As String
Dim sAttr As String

sDriver = "SQL Server"
'Which SQL Server do you want to connect to?
sAttr = "SERVER=cp1" & Chr$(0)
'DSN Name
sAttr = sAttr & "DSN=" & sDSN & Chr$(0)
'Change the default database to "a"
sAttr = sAttr & "DATABASE=a" & Chr$(0)
'With Windows NT authentication using the network login ID
sAttr = sAttr & "Trusted_Connection=Yes" & Chr$(0)
'Preform translation for character data
sAttr = sAttr & "AutoTranslate=No" & Chr$(0)
'Create
CreateDSN = SQLConfigDataSource(0&, ODBC_ADD_DSN, sDriver, sAttr)

End Function

Public Function DeleteDSN(ByVal sDSN As String) As Boolean
Dim sDriver As String
Dim sAttr As String

sDriver = "SQL Server"
sAttr = sAttr & "DSN=" & sDSN & Chr$(0)

DeleteDSN = SQLConfigDataSource(0&, ODBC_REMOVE_DSN, sDriver, sAttr)
End Function