Public strSQLServer As String 'SQL服务器地址
Public strSQLUser As String 'SQL用户名
Public strSQLPW As String 'SQL密码
Public strSQLDB As String 'SQL数据库
Public cnMain As New ADODB.Connection '主连接

'连接SQL服务器
Public Function sqlConnect(ByVal cnThis As ADODB.Connection, ByVal strServer As String, ByVal strUser As String, ByVal strPass As String, Optional ByVal strDataBase As String = "")
Dim strSQL As String
'生成连接字符串
strSQL = "provider=sqloledb;server=" & strServer & ";user id=" & strUser & ";password=" & strPass
If strDataBase <> "" Then strSQL = strSQL & ";database=" & strDataBase '如果需要连接到数据库
cnThis.Open strSQL
End Function

'读取SQL服务器配置信息
Public Sub readServer()
On Error GoTo aaaa
Dim strTmp As String, strT() As String
Open GetApp & "Files\sql.inf" For Input As #1
If EOF(1) = False Then Line Input #1, strTmp
Close #1
strTmp = Trim(strTmp)
If strTmp <> "" Then
strT = Split(strTmp, "||")
For i = 0 To 3
strT(i) = strT(i)
Next
strSQLServer = strT(0)
strSQLUser = strT(1)
strSQLPW = strT(2)
strSQLDB = strT(3)
End If
Exit Sub
aaaa:
strSQLServer = ""
strSQLUser = ""
strSQLPW = ""
strSQLDB = ""
End Sub

'保存SQL服务器配置信息
Public Sub SaveServer(ByVal strServer As String, ByVal strUser As String, ByVal strPass As String, ByVal strDataBase)
On Error GoTo aaaa
Open GetApp & "Files\sql.inf" For Output As #1
Print #1, strServer & "||" & strUser & "||" & strPass & "||" & strDataBase
Close #1
Exit Sub
aaaa:
MsgBox "保存 SQL 服务器信息失败！", vbCritical
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdOK_Click()
On Error GoTo aaaa
If txtServer.Text = "" Then
MsgBox "必须填写 SQL 服务器名称或 IP 地址。", vbInformation
txtServer.SetFocus
Exit Sub
End If
If txtUser.Text = "" Then
MsgBox "必须填写 SQL 服务器的用户名。", vbInformation
txtUser.SetFocus
Exit Sub
End If
If txtDB.Text = "" Then
MsgBox "必须填写数据库的名称。", vbInformation
txtDB.SetFocus
Exit Sub
End If
lbCT.Visible = True
DoEvents
Dim cnTest As New ADODB.Connection
sqlConnect cnTest, txtServer.Text, txtUser.Text, txtPW.Text, txtDB.Text
MsgBox "连接 " & txtServer.Text & " 成功！", vbInformation
cnTest.Close
SaveServer txtServer.Text, txtUser.Text, txtPW.Text, txtDB.Text
readServer
Unload Me
Exit Sub
aaaa:
MsgBox Err.Description, vbCritical
lbCT.Visible = False
End Sub

ADO。