数据库连接出错！！！！

[Jackile]

Private Sub Command1_Click()
OpenConnection
If Err.Number = 0 Then
MsgBox "数据连接成功", vbOKOnly, "数据库连接成功"
End If
End Sub
'以上是一个窗体，窗体上有一个按钮控件，Command1,caption为测试数据库连接！

这是我连接SQLServer数据库的一个模块！
Public rsNew As ADODB.Recordset
Public cnNew As ADODB.Connection
Public addFlag As Boolean
'*****************************************
'*名称：OpenConnection
'*功能：打开数据库连接
'*****************************************

Public Function OpenConnection() As Boolean
Dim sMsg As String
On Error GoTo strErrHandle
Set cnNew = New ADODB.Connection
cnNew.ConnectionTimeout = 25
cnNew.Provider = "sqloledb"
'cnNew.Properties("data source").Value = "MYSERVER" '服务器名 ★★★★★
cnNew.Properties("initial catalog").Value = "gzgl" '库名
cnNew.Properties("integrated security").Value = "SSPI" '登陆类型
cnNew.Properties("user id").Value = "sa"
cnNew.Properties("password").Value = "sa"
cnNew.Open

OpenConnection = True
addFlag = True
Exit Function

strErrHandle:
sMsg = "数据库连接失败，请检查数据库是否存在！"
MsgBox sMsg, vbCritical + vbOKOnly, "数据库连接失败"
addFlag = False
End

End Function

Public Sub CloseConnection()
'关闭数据库
On Error Resume Next
If cnNew.State <> adStateClosed Then cnNew.Close
Set cnNew = Nothing
End Sub
'*****************************************
'*名称：GetRecordset
'*功能：连接数据库记录集
'*****************************************
Public Function GetRecordset(ByVal strSQL As String) As Boolean
Dim strMsg As String
Dim bReturn As Boolean
On Error GoTo strErrHandle
Set rsNew = New ADODB.Recordset
If addFlag = False Then bReturn = OpenConnection

With rsNew
.ActiveConnection = cnNew
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open strSQL
End With
addFlag = True
GetRecordset = True
Exit Function

strErrHandle:
strMsg = "数据库生成结果出错！"
MsgBox strMsg, vbCritical + vbOKCancel, "数据库连接失败"
GetRecordset = False
End

End Function
Public Sub CloseRecordset()
'关闭数据集
On Error Resume Next
If rsNew.State <> adStateClosed Then rsNew.Close
Set rsNew = Nothing
End Sub

问题：1、我的SQL Server服务器是MYSERVER，我想通过代码自动获得本机SQL Server服务器名，同时想实现如果我的程序在没有安装SQL Server数据库的时候，提示安装！
2、我以上给出的代码是完全正确的，为了进行测试我把服务器名改为Server1，然后调试，程序无法响应也不报错，照理来说应该提示：数据库连接失败，请检查数据库是否存在！"的啊，改了一个当前不存在的服务器名，就程序中断，不知道各位有没有遇到过这个问题！急切地想解决这个问题！问题解决即结贴！

[Lionking1027]

代码太长,看了就昏,帮你UP先!

[lovehwq21]

不懂，加个SET呢
set namX = oSQLServerDMOApp.ListAvailableSQLServers

[Jackile]

可以了，多谢各位了！

[of123]

给一点题外的建议：既然函数返回值是Boolean型，addFlag似乎多余。另，err对象是不能跨模块的。这样好不好：

Private Sub Command1_Click()
If OpenConnection Then
MsgBox "数据连接成功", vbOKOnly, "数据库连接成功"
End If
End Sub

[射天狼]

我试了,是提示数据库连接失败啊!
是不是你的系统问题~~

[feiqinfeiwhw]

不懂

[Jackile]

To cuizm(射天狼):
'cnNew.Properties("data source").Value = "MYSERVER" '服务器名 ★★★★★
改为'cnNew.Properties("data source").Value = "" '服务器名 ★★★★★

数据库用你自己的啊！再试试啊！

[busisoft]

引用Microsoft SQLDMO Object Library
OpenConnection修改如下：
Public Function OpenConnection() As Boolean
Dim sMsg As String
On Error GoTo strErrHandle
Set cnNew = New ADODB.Connection
cnNew.ConnectionTimeout = 25
cnNew.Provider = "sqloledb"
cnNew.Properties("data source").Value = "MYSERVER" '服务器名 ★★★★★
cnNew.Properties("initial catalog").Value = "gzgl" '库名
cnNew.Properties("integrated security").Value = "SSPI" '登陆类型
cnNew.Properties("user id").Value = "sa"
cnNew.Properties("password").Value = "sa"
cnNew.Open
'利用 SQL DMO Application 对象查找可用的SQL服务器
Dim oSQLServerDMOApp As New SQLDMO.Application
Dim namX As SQLDMO.NameList
Dim i As Integer

'ListAvailableSQLServers方法枚举服务器列表
namX = oSQLServerDMOApp.ListAvailableSQLServers

For i = 1 To namX.Count

If MYSERVER = namX.Item(i) Then
OpenConnection = True
addFlag = True
Exit Function
End If

Next

sMsg = "数据库连接失败，请检查数据库是否存在！"
MsgBox sMsg, vbCritical + vbOKOnly, "数据库连接失败"
addFlag = False
Exit Function

strErrHandle:
Err.Raise Err.Number, , Err.Description

End Function

[Jackile]

of123() 谢谢你提醒，不过我已经改掉了你所说的那个，已经结贴了！下次有问题再问你吧！！！

[Jackile]

非常感谢 busisoft(chunlin) ：
但是编译时出现如下错误：

编译错误：
赋值号左边的函数调用必须返回变体或对象！！
错误行：namX = oSQLServerDMOApp.ListAvailableSQLServers
是不是缺少一个返回值啊，这个问题急待解决，再帮忙看一下吧！