用VB如何检测到MS SQL Server 正在运行的实例?
本机上如何检测,局域网上的又如何检测?
请指教!
本机上如何检测,局域网上的又如何检测?
请指教!
解决方案 »
- 数字签名提示asn1 bad tag value met 错误!
- 提问!
- 问个很sb的问题,急求!
- 《合同管理系统》,用VB和SQL!
- 如何解决从TextBox控件中复制出来的文本显示乱码问题?
- 诺大个VB版居然没有个像样的VB颜色转网页颜色的代码,我贴一个吧!
- 休闲1小时,谁有好点子?up者有分~!
- VB中画出圆后怎么选中它呢?
- 请问,如何在datagrid中修改数据并回写到数据库中去?
- 在程序另一处,treeitem获得焦点后,TreeItem_NodeClick不能用???
- datacombo控件如何能显示两列内容呀?我想显示ado记录集中的两列内容而不是一列,可以实现吗?
- gps/gprs 关于数据接收的问题,急,请教高手,高分!!
If Nsqlser.ListCount > 0 Then Exit Sub
Dim Server As SQLDMO.NameList '名字列表namelist
Dim appDMO As New SQLDMO.Application 'sqldmo应用
Dim i As Integer
Set Server = appDMO.ListAvailableSQLServers '得到所有的sql sever 列表
For i = 1 To Server.Count
Nsqlser.AddItem Server(i) 'Nsqlser为下拉列表框
NextEnd Sub
等我整理出来给你
'描 述:SQL 服务器数据库结构生成器
'****************************************************************************
Option ExplicitPrivate Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_NORMAL = 1Private Sub cboDatabaseName_Click()Dim errhandle As LabelOn Error GoTo errhandlefrmSQLServerDocumenter.MousePointer = 11
Fill_cboTableName
frmSQLServerDocumenter.MousePointer = 0
Exit Suberrhandle:
frmSQLServerDocumenter.MousePointer = 0
MsgBox "未知错误:" & vbCrLf & Err.Description & vbCrLf & Err.Number, vbCritical, "错误"
End SubPrivate Sub cboSQLServerList_Change()End SubPrivate Sub cmdConnect_Click()Dim errhandle As LabelOn Error GoTo errhandleIf cboSQLServerList.ListIndex < 1 Then
MsgBox "请选择一个服务器。", vbCritical, "错误"
Exit Sub
End IfSelect Case cmdConnect.Caption
Case "连接"
lblStatus.Caption = "连接中..."
picConnectionStatus.Picture = imlConnectionStatus.ListImages(2).Picture
lblStatus.Refresh
If optSQLAuth.Value = True Then
Set objSQLServer = New SQLDMO.SQLServer
objSQLServer.Connect cboSQLServerList.Text, txtUserName.Text, txtPassword.Text
txtUserName.Enabled = False
txtPassword.Enabled = False
ElseIf optWinAuth.Value = True Then
Set objSQLServer = New SQLDMO.SQLServer
objSQLServer.LoginSecure = True
objSQLServer.Connect cboSQLServerList.Text
End If
cmdConnect.Caption = "断开连接"
blnConnectionState = True
Fill_cboDatabaseName
cboSQLServerList.Enabled = False
optSQLAuth.Enabled = False
optWinAuth.Enabled = False
lblStatus.Caption = "已连接"
picConnectionStatus.Picture = imlConnectionStatus.ListImages(1).Picture
Case "断开连接"
lblStatus.Caption = "断开中..."
picConnectionStatus.Picture = imlConnectionStatus.ListImages(4).Picture
lblStatus.Refresh
objSQLServer.DisConnect
Set objSQLServer = Nothing
cmdConnect.Caption = "连接"
blnConnectionState = False
cboSQLServerList.Enabled = True
If optSQLAuth.Value = True Then
txtUserName.Enabled = True
txtPassword.Enabled = True
End If
optSQLAuth.Enabled = True
optWinAuth.Enabled = True
cboDatabaseName.Clear
cboTableName.Clear
lsvTableData.ListItems.Clear
lblStatus.Caption = "未连接"
picConnectionStatus.Picture = imlConnectionStatus.ListImages(3).Picture
End Select
Exit Sub
errhandle:
lblStatus.Caption = "连接失败"
picConnectionStatus.Picture = imlConnectionStatus.ListImages(5).Picture
MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdExport2XLS_Click()Dim errhandle As LabelOn Error GoTo errhandleIf cboTableName.Text = "" Then
MsgBox "请选择一个表。", vbCritical, "错误"
Exit Sub
End IfMe.MousePointer = 11
dlgExport.DialogTitle = "导出到Excel文件"
dlgExport.DefaultExt = ".xls"
dlgExport.Filter = "Excel 工作薄|*.xls"
dlgExport.ShowSaveIf dlgExport.FileName = "" Then
Exit Sub
End IfExport2XLS cboTableName.Text, dlgExport.FileName, cboSQLServerList.Text, cboDatabaseName.TextMe.MousePointer = 0
Exit Sub
errhandle:
Me.MousePointer = 0
MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdPreviewPrint_Click()Dim errhandle As LabelOn Error GoTo errhandleIf cboTableName.Text = "" Then
MsgBox "请选择一个表。", vbCritical, "错误"
Exit Sub
End IfPrintPreview cboTableName.Text, cboDatabaseName.Text, cboSQLServerList.TextfrmPrintPreview.Show 1Exit Sub
errhandle:
MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdShowIndexes_Click()Dim errhandle As LabelOn Error GoTo errhandle
blnShowTable = FalseIf cboTableName.ListIndex < 1 Then
MsgBox "请选择一个表。", vbCritical, "错误"
Exit Sub
End IffrmSQLServerDocumenter.MousePointer = 11
Format_lsvIndex
Fill_lsvIndex
frmSQLServerDocumenter.MousePointer = 0Exit Sub
errhandle:
frmSQLServerDocumenter.MousePointer = 0
MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdShowTable_Click()Dim errhandle As LabelOn Error GoTo errhandle
blnShowTable = TrueIf cboTableName.ListIndex < 1 Then
MsgBox "P请选择一个表。", vbCritical, "错误"
Exit Sub
End IffrmSQLServerDocumenter.MousePointer = 11
Format_lsvTable
Fill_lsvTable
frmSQLServerDocumenter.MousePointer = 0Exit Sub
errhandle:
frmSQLServerDocumenter.MousePointer = 0
MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub fmeAbout_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)If X > 0 And X < fmeAbout.Width And Y > 0 And Y < fmeAbout.Height Then
If GetCapture <> fmeAbout.hwnd Then
lblAbout.ForeColor = vbBlue
lblAbout.FontUnderline = True
SetCapture fmeAbout.hwnd
End If
Else
lblAbout.ForeColor = vbBlack
lblAbout.FontUnderline = False
ReleaseCapture
End If
End SubPrivate Sub Form_Load()frmSplash.Show
DoEvents
Me.Caption = "SQL 服务器数据库结构生成器 v" & App.Major & "." & App.Minor & "." & App.Revision
Center Me
frmSplash.lblStatus.Caption = "正在初始化环境...."
frmSplash.lblStatus.Refresh
InitArray
txtUserName.Enabled = False
txtPassword.Enabled = False
txtUserName.BackColor = &H8000000F
txtPassword.BackColor = &H8000000F
frmSplash.lblStatus.Caption = "正在搜索网络中的 SQL 服务器..."
frmSplash.lblStatus.Refresh
Fill_cboSQLServerList
blnConnectionState = False
picConnectionStatus.Picture = imlConnectionStatus.ListImages(3).Picture
Unload frmSplashEnd SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)If blnConnectionState = True Then
cmdConnect_Click
Set objSQLServer = Nothing
End IfEnd Sub
Private Sub Form_Resize()If Me.WindowState <> 1 Then
Me.Width = 9945
Me.Height = 7200
End IfEnd SubPrivate Sub lblAbout_Click()
ShellExecute Me.hwnd, "open", "http://www.mndsoft.com/", vbNullString, vbNullString, SW_NORMAL
End SubPrivate Sub optSQLAuth_Click()txtUserName.Enabled = True
txtPassword.Enabled = True
txtUserName.BackColor = &H80000005
txtPassword.BackColor = &H80000005
txtUserName.SetFocusEnd SubPrivate Sub optWinAuth_Click()txtUserName.Enabled = False
txtPassword.Enabled = False
txtUserName.BackColor = &H8000000F
txtPassword.BackColor = &H8000000F
txtUserName.Text = ""
txtPassword.Text = ""End Sub'搜索网络内的SQL服务器
Sub Fill_cboSQLServerList()Dim ServerList As SQLDMO.NameList
Dim SQLApp As SQLDMO.Application
Dim lngCounter As LongSet SQLApp = New SQLDMO.Application
Set ServerList = SQLApp.ListAvailableSQLServerscboSQLServerList.AddItem ""
cboSQLServerList.ItemData(cboSQLServerList.NewIndex) = 0For lngCounter = 1 To ServerList.Count
cboSQLServerList.AddItem ServerList.Item(lngCounter)
cboSQLServerList.ItemData(cboSQLServerList.NewIndex) = lngCounter
NextEnd SubSub Fill_cboDatabaseName()Dim lngCounter As LongcboDatabaseName.ClearcboDatabaseName.AddItem ""
cboDatabaseName.ItemData(cboDatabaseName.NewIndex) = 0For Each objDatabase In objSQLServer.Databases
If (Not objDatabase.SystemObject = True) Then
cboDatabaseName.AddItem objDatabase.Name
cboDatabaseName.ItemData(cboDatabaseName.NewIndex) = lngCounter
lngCounter = lngCounter + 1
End If
NextEnd SubSub Fill_cboTableName()Dim lngCounter As LongIf cboDatabaseName.ListIndex < 1 Then
MsgBox "请选择一个数据库!", vbCritical, "错误"
Exit Sub
End IfSet objTable = New SQLDMO.Table
Set objDatabase = objSQLServer.Databases(cboDatabaseName.Text)
cboTableName.ClearcboTableName.AddItem ""
cboTableName.ItemData(cboTableName.NewIndex) = 0For Each objTable In objDatabase.Tables
If Not objTable.SystemObject = True Then
cboTableName.AddItem objTable.Name
cboTableName.ItemData(cboTableName.NewIndex) = lngCounter
lngCounter = lngCounter + 1
End If
NextEnd SubSub Format_lsvTable()Dim itmX As ColumnHeaderlsvTableData.ColumnHeaders.ClearSet itmX = lsvTableData.ColumnHeaders.Add(, , "列名", 2500)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "数据类型", 2500)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "长度", 1000)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "允许空", 1500)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "标识", 1000)lsvTableData.View = lvwReportEnd SubSub Format_lsvIndex()Dim itmX As ColumnHeaderlsvTableData.ColumnHeaders.ClearSet itmX = lsvTableData.ColumnHeaders.Add(, , "索引名", 2000)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "索引类型", 3000)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "索引字段", 3700)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "% 填充", 600, vbCenter)lsvTableData.View = lvwReportEnd SubSub Fill_lsvTable()Dim lngCounter As Long
Dim itmY As ListItem
Dim objIndex As SQLDMO.Index
Dim objTable As SQLDMO.TablelsvTableData.ListItems.ClearSet objColumn = New SQLDMO.Column
Set objTable = objDatabase.Tables(cboTableName.Text)For Each objColumn In objTable.Columns
Set itmY = lsvTableData.ListItems.Add(, "U" & lngCounter, objColumn.Name)
itmY.SubItems(1) = objColumn.Datatype
itmY.SubItems(2) = objColumn.Length
itmY.SubItems(3) = objColumn.AllowNulls
itmY.SubItems(4) = objColumn.Identity
lngCounter = lngCounter + 1
NextEnd SubSub Fill_lsvIndex()Dim lngCounter As Long
Dim itmY As ListItem
Dim objIndex As SQLDMO.Index
Dim objTable As SQLDMO.Table
Dim objColumn As SQLDMO.Column
Dim strIndexedFields As String
Dim intCount As IntegerlsvTableData.ListItems.ClearSet objIndex = New SQLDMO.Index
Set objTable = objDatabase.Tables(cboTableName.Text)For Each objIndex In objTable.Indexes
If Left(objIndex.Name, 8) <> "_WA_Sys_" And Left(objIndex.Name, 5) <> "hind_" Then
Set itmY = lsvTableData.ListItems.Add(, "U" & lngCounter, objIndex.Name)
itmY.SubItems(1) = DecodeIDXType(objIndex.Type)
For intCount = 1 To objIndex.ListIndexedColumns.Count
Set objColumn = objIndex.ListIndexedColumns.Item(intCount)
strIndexedFields = strIndexedFields & objColumn.Name & ", "
Next
itmY.SubItems(2) = Left(strIndexedFields, Len(strIndexedFields) - 2)
itmY.SubItems(3) = objIndex.FillFactor
lngCounter = lngCounter + 1
End If
strIndexedFields = ""
NextEnd Sub