frmload.frm

VB远程操作Sql Server 2000数据库的工具 主要功能就是远程（局域网）操作Sql Server数据库。 包括： 搜索并列举局域网内的所有Sql Server服务器 搜索并列举Sql

      End
   End
   Begin VB.Frame Frame2 
      Height          =   735
      Left            =   120
      TabIndex        =   9
      Top             =   5280
      Width           =   5895
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "请慎重..."
         ForeColor       =   &H00FF0000&
         Height          =   180
         Left            =   120
         TabIndex        =   10
         Top             =   240
         Width           =   810
      End
   End
End
Attribute VB_Name = "FrmLoad"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Dim Server As SQLDMO.NameList  '列举服务器
Dim appDMO As New SQLDMO.Application '列举服务器

'Dim Cn As New adodb.Connection
Dim Rs As New adodb.Recordset
Dim Rs1 As New adodb.Recordset

Dim Intes As Integer '设置文件
Dim Str, LIn As String '设置文件

Dim I As Integer
Dim Msg As String
Dim SqlString As String

Sub SQLServerList() '刷新服务器
  On Error GoTo errHandle
  ' DoEvents
  'ShellExecute 0, vbNullString, App.Path & "\SQLTool_信息.exe", "No1", vbNullString, vbNormalFocus
  
  
  FrmMsgbox.LabelInfor.Caption = "正在搜索可连接的 SQL Server 服务器，请等待..."
  FrmMsgbox.Show
  'MsgBox "若您不回应的话，3 秒后此 MsgBox 会自动关闭", 64, MsgTitle
  Me.Enabled = False
  Set Server = appDMO.ListAvailableSQLServers '得到所有的sql server 列表
   If Server.Count > 0 Then
   
     ComboSQLServerName.Clear
      For I = 1 To Server.Count
        ComboSQLServerName.AddItem Server(I)
      Next
      ComboSQLServerName.ListIndex = 0
    Else
      MsgBox "没有找到数据库服务器，如果您知道服务器名可手工输入。"
    End If
    
    ''Delay (500)
    'AppExit ("MsgTitle")
    'AppExit ("SQLTool_信息")
    Unload FrmMsgbox
    Me.Enabled = True
errHandle:
    ''Delay (500)
    'AppExit ("SQLTool_信息")
    'AppExit ("SQLTool_信息")
    Unload FrmMsgbox
    Me.Enabled = True
  If Err.Number <> 0 Then
     MsgBox "错误代码：" & Err.Number & vbCrLf & Err.Description
  End If
 ' Err.Clear
  'Resume Next
End Sub

Sub Load_Set() '读入数据库用户、密码
  On Error Resume Next
   List1.Clear
     Str = App.Path & "\IinFile\LoadInfo.ini"
     Intes = FreeFile()
     If Dir(Str) <> "" Then
       Open Str For Input As #Intes
         Do Until EOF(Intes) 'Do Until:当条件不成立时执行以下代码
           Line Input #Intes, LIn
           List1.AddItem VBA.Trim(LIn)
         Loop
       Close #Intes
     Else
       ComboSQLServerName.Text = ComputerNameGet()
     End If
     
  If List1.ListCount > 0 Then
    'For I = 0 To List1.ListCount - 1
    ComboSQLServerName.Text = List1.List(0)
    TextLoadName.Text = List1.List(1)
    TextLoadPassword.Text = List1.List(2)
    ComboDName.Text = List1.List(3)
    'Next
  End If
End Sub

Sub Save_Set()
  Intes = FreeFile()
  
  If Check1.Value = 1 Then
    Open App.Path & "\IinFile\LoadInfo.ini" For Output As #Intes
      Print #Intes, ComboSQLServerName.Text '服务器名称
      Print #Intes, TextLoadName.Text '登录ID
      Print #Intes, TextLoadPassword '登录密码
      Print #Intes, ComboDName.Text '数据库名称
    Close #Intes
  End If
End Sub


Private Sub Command1_Click()
    CommonD.Filter = "数据库文件(*.MDF)|*.MDF|所有文件(*.*)|*.*"
    CommonD.FileName = ""
    CommonD.FLAGS = cdlOFNHideReadOnly + cdlOFNFileMustExist
    CommonD.ShowOpen
    
    If Len(CommonD.FileName) > 0 Then
      Text1.Text = CommonD.FileName
    End If
    
End Sub

Private Sub Command2_Click()
    CommonD.Filter = "日志文件(*.LDF)|*.LDF|所有文件(*.*)|*.*"
    CommonD.FileName = ""
    CommonD.FLAGS = cdlOFNHideReadOnly + cdlOFNFileMustExist
    CommonD.ShowOpen
    
    If Len(CommonD.FileName) > 0 Then
      Text2.Text = CommonD.FileName
    End If
End Sub


Private Sub CommandCreateData_Click()
  CreateData
End Sub

Sub CreateData()

On Error GoTo err1
  FrmCreateData.Show
  FrmCreateData.ComboSQLServerName.Text = ComboSQLServerName.Text
  FrmCreateData.TextLoadName.Text = TextLoadName.Text
  FrmCreateData.TextLoadPassword.Text = TextLoadPassword.Text
  
  CnnData adUseClient, "sqloledb", ComboSQLServerName.Text, "master", TextLoadName.Text, TextLoadPassword.Text, "adPromptNever", 15
  SqlString = "select phyname from sysdevices where name='master'"

  Set Rs = Cns.Execute(SqlString)
  Rs.MoveFirst
  FrmCreateData.TextPath.Text = Left(Rs.Fields("phyname").Value, InStrRev(Rs.Fields("phyname").Value, "\"))
  FrmCreateData.LabelPath.Caption = Left(Rs.Fields("phyname").Value, InStrRev(Rs.Fields("phyname").Value, "\"))
  Cns.Close
err1:
  If Err.Number <> 0 Then
    MsgBox "错误代码：" & Err.Number & vbCrLf & Err.Description
    Err.Clear
    Unload FrmCreateData
    Exit Sub
    EXT
  End If
End Sub

Private Sub CommandDelData_Click()
  DeleteData
End Sub

Sub DeleteData()
  On Error GoTo err1
  If ComboDName.Text <> "" Then
    Msg = MsgBox("确定要删除数据库 " & ComboDName.Text & " 吗？删除后将不能恢复。" & vbCrLf & "请慎重！建议备份后再进行该操作！要继续删除吗？", vbSystemModal + vbOKCancel + vbInformation, "询问提示")
    If Msg = vbOK Then
       CnnData "adUseClient", "sqloledb", ComboSQLServerName.Text, "master", TextLoadName.Text, TextLoadPassword.Text, "adPromptNever", 15
       SqlString = "Drop Database " + ComboDName.Text + ""

       Rs.Open SqlString, Cns
       EXT
  
       MsgBox "数据库 " & ComboDName.Text & " 删除成功！"
       ComboDName.RemoveItem (ComboDName.ListIndex)
'       Cns.Close
       
     End If
  Else
     MsgBox "没有选择或输入数据库名称，请选择或输入数据库名称！"
     ComboDName.SetFocus
  End If
err1:
  If Err.Number <> 0 Then
    MsgBox "错误代码：" & Err.Number & vbCrLf & Err.Description
    Err.Clear
    EXT
  End If
End Sub


Private Sub CommandExit_Click()
  End
End Sub

Private Sub CommandInto_Click()
On Error GoTo errHandle
'On Error Resume Next
  Dim sSql As String

  CnnData adUseClient, "sqloledb", ComboSQLServerName.Text, "master", TextLoadName.Text, TextLoadPassword.Text, "adPromptNever", 15
  'sSql = "select * from sysdatabases where filename like '" + Text1.Text + "'"

  Rs.CursorLocation = adUseClient '避免RecordCount=-1
  Rs1.CursorLocation = adUseClient '避免RecordCount=-1

  Rs.Open "select * from sysdatabases where name like '" + Text3.Text + "'", Cns
  Rs1.Open "select * from sysdatabases where filename like '" + Text1.Text + "'", Cns

  'Set Rs = Cns.Execute(sSql)
  'Rs.MoveFirst

  If Rs.RecordCount > 0 Then
    MsgBox "数据库 " & ComboDName & " 已存在！请重新输入名称...", 16, "请重新输入名称"
    Exit Sub
  Else
    If Rs1.RecordCount > 0 Then
      Msg = MsgBox("数据库文件 " & Text1.Text & vbCrLf & " 已被其他数据库使用！如继续导入则使用该文件的其他数据库将不能使用，继续吗？", vbOKCancel + vbSystemModal + vbInformation, "警告")
      
      If Msg = vbOK Then
        If Text3.Text <> "" Then
          If Text1.Text <> "" Then
            If Text2.Text <> "" Then
              sSql = "sp_attach_db " + Text3.Text + ",'" + Text1.Text + "','" + Text2.Text + "'"
              Cns.Execute sSql     '附加数据库
            Else
              sSql = "sp_attach_db " + Text3.Text + ",'" + Text1.Text + "'"
              Cns.Execute sSql     '附加数据库
            End If
          Else
            MsgBox "没有选择MDF文件，请选择MDF文件..."
            Rs.Close
            Rs1.Close
            Cns.Close
            Exit Sub
          End If
        Else
          MsgBox "没有输入数据库名，请输入数据库名..."
          Rs.Close
          Rs1.Close
          Cns.Close
          Text3.SetFocus
          Exit Sub
        End If
      Else
        Exit Sub
      End If
      
    Else
      If Text3.Text <> "" Then
        If Text1.Text <> "" Then
          If Text2.Text <> "" Then
            sSql = "sp_attach_db " + Text3.Text + ",'" + Text1.Text + "','" + Text2.Text + "'"
            Cns.Execute sSql     '附加数据库
          Else
            sSql = "sp_attach_db " + Text3.Text + ",'" + Text1.Text + "'"
            Cns.Execute sSql     '附加数据库
          End If
        Else
          MsgBox "没有选择MDF文件，请选择MDF文件..."
          Rs.Close
          Rs1.Close
          Cns.Close
          
          Exit Sub
        End If
      Else
        MsgBox "没有输入数据库名，请输入数据库名..."
        Rs.Close
        Rs1.Close
        Cns.Close
        
        Text3.SetFocus
        Exit Sub
      End If
    End If
  End If

  Rs.Close
  Rs1.Close
  Cns.Close
  
errHandle:
  If Err.Number = 0 Then
    MsgBox "导入文件成功！"
  Else
    MsgBox "导入文件失败！"
  End If

End Sub

Private Sub CommandIntoShow_Click()
  Select Case CommandIntoShow.Caption
    Case "导入数据库文件"
      Frame3.Visible = True
      CommandIntoShow.Caption = "隐藏导入栏"
      Frame2.Top = Frame3.Top + Frame3.Height
      Me.Height = 6525
      
    Case "隐藏导入栏"
      Frame2.Top = Frame3.Top
      Frame3.Visible = False
      CommandIntoShow.Caption = "导入数据库文件"
      Me.Height = 4845
  End Select
End Sub

Private Sub CommandLoad_Click()
  Save_Set
  Me.Visible = False
  FrmMain.LableSqlServerName = ComboSQLServerName.Text
  
  If ComboSQLServerName.Text = "(local)" Then
    FrmMain.LableSqlServerIP = GetIPAddress()
  Else
    FrmMain.LableSqlServerIP = GetIPAddress(ComboSQLServerName.Text)
  End If
  
  FrmMain.LabelSqlDataName = ComboDName.Text
  FrmMain.LabelSqlLoadName = TextLoadName.Text
  FrmMain.LabelSqlLoadPassword = TextLoadPassword.Text
  FrmMain.Show
  FrmMain.Refresh
  
  FrmMain.OpenDataList
 
  'Unload Me
End Sub

Private Sub CommandRnameData_Click()
  ReNameData
End Sub

Sub ReNameData()
  Dim NewFileName As String
On Error GoTo err1
  NewFileName = InputBox(vbCrLf & "原数据库名为：" & ComboDName.Text & vbCrLf & vbCrLf & vbCrLf & "请输入新数据库名：", "数据库改名", "")
  If VBA.Trim(NewFileName) <> "" Then
    Msg = MsgBox("修改数据库名会导致其他用户不能访问该数据库，要继续吗？", vbOKCancel + vbSystemModal + vbQuestion, "询问")
    
    If Msg = vbOK Then
      CnnData "adUseClient", "sqloledb", ComboSQLServerName.Text, "master", TextLoadName.Text, TextLoadPassword.Text, "adPromptNever", 15
      Cns.Execute "sp_renamedb " + ComboDName.Text + ", " + NewFileName + ""
      Cns.Close
      ComboDName.RemoveItem (ComboDName.ListIndex)
      ComboDName.Text = NewFileName
      MsgBox "数据库名称已更改，请重新搜索数据库..."

    End If
  End If
err1:
  If Err.Number <> 0 Then
    MsgBox "错误代码：" & Err.Number & vbCrLf & Err.Description
    Cns.Close
    Exit Sub
  End If
End Sub

Private Sub CommandServerList_Click()
  Active_Enabled Me, False
  SQLServerList
  Active_Enabled Me, True
End Sub

  
Sub SQL_DataName()
  Dim SQLServerX As New SQLDMO.SQLServer
  ComboDName.Clear
  
  SQLServerX.Connect ComboSQLServerName.Text, TextLoadName.Text, TextLoadPassword.Text
  
  For I = 0 To SQLServerX.Databases.Count - 1
    ComboDName.AddItem SQLServerX.Databases.Item(I + 1).Name
  Next I
  ComboDName.ListIndex = 0
End Sub
  
Private Sub CommandFindData_Click()
  On Error GoTo errHandle
   Active_Enabled Me, False

   If ComboSQLServerName.Text <> "" Then
     
     FrmMsgbox.LabelInfor.Caption = "正在搜索服务器 " & ComboSQLServerName.Text & " 上的数据库，请等待..."
     FrmMsgbox.Show
     SQL_DataName
     
     Unload FrmMsgbox
   Else
     MsgBox "没有指定服务器名，请搜索或输入服务器名。", vbInformation + vbOKOnly, "提示"
   End If
  Active_Enabled Me, True

errHandle:
  'Delay (500)
  Unload FrmMsgbox

  If Err.Number <> 0 Then
    MsgBox "错误代码：" & Err.Number & vbCrLf & Err.Description
    Active_Enabled Me, True
  End If
End Sub

Private Sub Form_Load()
  Call CheckExist(Me)
  
  Frame2.Top = Frame3.Top
  Frame3.Visible = False
  CommandIntoShow.Caption = "导入数据库文件"
  Me.Height = 4845
  
  Label2.Caption = "警告：某些功能对数据库的改变可能会导致其他程序不能正常访问" & vbCrLf & "数据库！请慎重使用！否则出了问题我不负责！"
  I = 0
  
  Load_Set
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  Unload FrmMsgbox
End Sub

Private Sub Form_Resize()
  'SetTopMostWindow Me.hwnd, True '使窗体位于最顶端
End Sub

Sub EXT()
  On Error GoTo err2
  Cns.Close
  Rs.Close
  Rs1.Close
  Set Server = Nothing
  Set appDMO = Nothing
err2:
  If Err.Number <> 0 Then
    Err.Clear
  End If
End Sub