VB自动加载局域网服务器,VB爱好者乐园(VBGood)

原帖由 hufeieagle 于 2007-7-25 16:50 发表

如何获取局域网中SQL数据库服务器和及它的数据库列表

Private BlnServersList As Boolean

Dim ztmc  As String

Private sysUserName As String

Private sysUserPassWord As String

Private sysServer As String

Private sysDBName As String

Private sysOption As String

Private sysConnStr As String

'初始化环境

Private Sub InitEnvi()

BlnServersList = False

Me.Option2.Value = True

Me.Text1(0).Text = "sa"

End Sub

'浏览某个数据库服务器(Server)的数据库如果浏览成功返回真值

Private Function ListDBServers(Server As String, UserName As String, Password As String, LoginOption As String, ErrDesc As String) As Boolean

On Error GoTo Err

Dim Conn As New ADODB.Connection

Dim Connstr As String

Dim DBLists As New ADODB.Recordset

Dim I As Integer, n As Integer

If LoginOption = 0 Then '集成身份验证

Connstr = &quot

rovider=SQLOLEDB.1;Integrated Security=SSPI

ersist Security Info=False;Initial Catalog='master';Data Source='" & Server & "'"

Else                    '用户名和密码验证

Connstr = &quot

rovider=SQLOLEDB.1;Persist Security Info=False;User ID=" & UserName & ";Password=" & Password & ";Initial Catalog='master';Data Source='" & Server & "'"

End If

Conn.ConnectionTimeout = 15

Conn.Open Connstr

DBLists.Open "select name from sysdatabases", Conn, adOpenStatic, adLockReadOnly, adCmdText

Combo1(1).Clear

n = DBLists.RecordCount

For I = 1 To n

Combo1(1).AddItem DBLists.Fields(0).Value

DBLists.MoveNext

Next

Set objNameList = Nothing

Set objApp = Nothing

ListDBServers = True

Exit Function

Err:

ErrDesc = Err.Description

ListDBServers = False

End Function

Private Sub Command1_Click(Index As Integer)

Dim ErrDesc As String

Select Case Index

Case 0 '刷新

Case 1 '确定

If Me.Combo1(1).Text = "" Then MsgBox "请选择数据库!", 48: Exit Sub

If Not TestConn(ErrDesc) Then MsgBox "连接错误,请重新设置参数!", 48: Exit Sub

If sysOption = 0 Then

sysConnStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog='" & sysDBName & "';Data Source='" & sysServer & "'"

ElseIf sysOption = 1 Then

sysConnStr = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=" & sysUserName & ";Password=" & sysUserPassWord & ";Initial Catalog='" & sysDBName & "';Data Source='" & sysServer & "'"

End If

SaveSettings

strconn = sysConnStr

Unload Me

Set sCn = New ADODB.Connection

sCn.Open strconn

frmSplash.Show 1

Case 2 '取消

End

Case 3 '测试连接

Me.MousePointer = vbHourglass

If Not TestConn(ErrDesc) Then

MsgBox "测试连接失败。" & vbCrLf & "详细资料:" & ErrDesc, vbExclamation, App.Title

Else

MsgBox "测试连接成功。", vbInformation, App.Title

End If

Me.MousePointer = vbDefault

Case 4   '保存

End Select

Exit Sub

err1:

MsgBox Error

End Sub

Private Sub Form_Load()

InitEnvi

GetSettings

End Sub

'测试数据库连接

Private Function TestConn(ErrDesc As String) As Boolean

Dim CnnTemp As New ADODB.Connection

On Error GoTo Err

SetsysValues

CnnTemp.ConnectionTimeout = 15

If sysOption = 0 Then

CnnTemp.Open "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog='" & sysDBName & "';Data Source='" & sysServer & "'"

ElseIf sysOption = 1 Then

CnnTemp.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=" & sysUserName & ";Password=" & sysUserPassWord & ";Initial Catalog='" & sysDBName & "';Data Source='" & sysServer & "'"

End If

TestConn = True

Exit Function

Err:

ErrDesc = Err.Description

TestConn = False

End Function

'保存数据连接属性

Private Sub SaveSettings()

SaveSetting App.EXEName, "Conn" & Me.Tag, "ConnString", sysConnStr

SaveSetting App.EXEName, "Conn" & Me.Tag, "sysUserName", sysUserName

SaveSetting App.EXEName, "Conn" & Me.Tag, "sysUserPassWord", sysUserPassWord

SaveSetting App.EXEName, "Conn" & Me.Tag, "sysServer", sysServer

SaveSetting App.EXEName, "Conn" & Me.Tag, "sysDBName", sysDBName

SaveSetting App.EXEName, "Conn" & Me.Tag, "sysOption", sysOption

End Sub

Private Sub Frame1_DragDrop(Source As Control, X As Single, Y As Single)

End Sub

Private Sub Option1_Click()

Me.Text1(0).Enabled = False

Me.Text1(1).Enabled = False

End Sub

Private Sub Option2_Click()

Me.Text1(0).Enabled = True

Me.Text1(1).Enabled = True

End Sub

Private Sub SetsysValues()

If Me.Option1.Value = True Then            '集成验证

sysServer = Me.Combo1(0).Text

sysDBName = Me.Combo1(1).Text

sysOption = 0

ElseIf Me.Option2.Value = True Then        '用户验证

sysUserName = Me.Text1(0).Text

sysUserPassWord = Me.Text1(1).Text

sysServer = Me.Combo1(0).Text

sysDBName = Me.Combo1(1).Text

sysOption = 1

End If

End Sub

Private Sub GetSettings()

On Error Resume Next

Me.Combo1(0).Text = GetSetting(App.EXEName, "Conn", "sysServer", "")

'  Me.Combo1(1).Text = GetSetting(App.EXEName, "Conn", "sysDBName", "")

If GetSetting(App.EXEName, "Conn", "sysOption", "") = 0 Then

Me.Option1.Value = False

ElseIf GetSetting(App.EXEName, "Conn", "sysOption", "") = 1 Then

Me.Option2.Value = True

Me.Text1(0).Text = GetSetting(App.EXEName, "Conn", "sysUserName", "")

Me.Text1(1).Text = GetSetting(App.EXEName, "Conn", "sysUserPassWord", "")

End If

End Sub