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
这是连接数据库的程序:
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
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
这是写配置文件的程序:
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
'************************************************
' 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