dbchecker.frm

数据库自动安装,为学员深入了解数据库编程语言提供方便。

        TriggerCheck.Value = 0
      Else
        Frame1.Enabled = True
        Defaults.Enabled = True
        StoredProc.Enabled = True
        TriggerCheck.Enabled = True
        Defaults.Value = 1
        StoredProc.Value = 1
        TriggerCheck.Value = 1
    End If

End Sub

Private Sub QuickDbChecker()

  Dim TextLine As String
  Dim tmp As String
  Dim cn As New rdoConnection
  Dim cpw As rdoQuery
  Dim tb As rdoResultset
  Dim tbf As rdoResultset
  Dim TbSet As rdoTable
  Dim coltb As rdoColumn
  Dim TempCol As rdoColumn
  Dim cn1 As New rdoConnection
  Dim TempTable As rdoTable
  Dim i As Integer
  Dim j As Integer
  Dim a As Integer
  Dim Till As Integer
  Dim found As Boolean
  Dim AnyError As Boolean
  Dim errorstring As String
  Dim ColFound As Boolean
  Dim inderrorstring As String
  Dim dbs As Integer
  Dim sql As String
  '-------------------------

    Text4 = ""
    ProgressBar1.Value = 0
    Screen.MousePointer = 11
    If Trim$(Text1) = "" Then
        MsgBox "请输入SQL语句数据库文件!", vbInformation, "操作提示"
        Exit Sub
    End If
    If Trim$(Text2) = "" Then
        MsgBox "请输入服务器名进行操作!", vbInformation, "操作提示"
        Exit Sub
    End If
    If DbList.ListCount = 0 Then
        MsgBox "请输入数据库文件名进行操作!", vbInformation, "操作提示"
        Exit Sub
    End If
    If Len(DbDrive) = 0 Then
        MsgBox "请输入安装数据库临时驱动器位置进行操作!", vbInformation, "操作提示"
        Exit Sub
    End If
    If Dir(Trim$(Text1)) = "" Then
        MsgBox "Script Not Found!", vbCritical
        Exit Sub
    End If
    passedTesting = True
    Close #1
    Open Trim(Text1) For Input As #1

    cn.Connect = "uid=sa;pwd=" & PassToPass & ";server=" & Text2 & ";driver={SQL Server};database=" & DbList.List(0) & ";DSN='';"
    cn.CursorDriver = rdUseOdbc

    tmp = "USE master" & Chr$(13) & Chr$(10)
    tmp = tmp & "select * from sysdatabases where name = 'TempStruc'"
        tmp = "USE master" & Chr$(13) & Chr$(10)
        tmp = "if exists (select * from sysdatabases where name = 'TempStruc') drop DATABASE TempStruc" & Chr$(13) & Chr$(10)
    DoEvents

    tmp = "USE master" & Chr$(13) & Chr$(10)
    tmp = tmp & "CREATE DATABASE TempStruc" & Chr$(13) & Chr$(10)
    tmp = tmp & "ON ( NAME = TempStruc_dat, FILENAME = '" & Trim$(DbDrive) & ":\TempStruc.mdf',SIZE = 10,MAXSIZE = 50,FILEGROWTH = 5)"
    tmp = tmp & "LOG ON ( NAME = 'TempStruc_log', FILENAME = '" & Trim$(DbDrive) & ":\TempStruclogs.ldf',SIZE = 5MB, MAXSIZE = 25MB,  FILEGROWTH = 5MB )"

    cn.Close
    Text4 = ":SQL Server数据库安装成功!" & Text4 & Chr$(13) & Chr$(10)

    cn.Connect = "uid=sa;pwd=" & PassToPass & ";server=" & Text2 & ";driver={SQL Server};database=TempStruc;DSN='';"
    cn.CursorDriver = rdUseOdbc
    cn.EstablishConnection rdDriverNoPrompt

    tmp = ""
    Do While Not EOF(1)
        Line Input #1, TextLine
        If Len(TextLine) > 1 Then
            If (Left$(UCase$(TextLine), 2)) <> "GO" Then
                tmp = tmp & Chr$(13) & Chr$(10) & TextLine

              Else
                On Error Resume Next
                    Set tb = cn.OpenResultset(tmp, 2, rdConcurRowVer)
                    tmp = ""
                End If
              Else
                tmp = tmp & Chr$(13) & Chr$(10) & TextLine
            End If
        Loop
    On Error GoTo 0
    DoEvents
    tb.Close
    '-------------'
    Close #1
    Text4 = "  数据库安装最终检查结果是" & Text4
    Text4.ForeColor = &HFF0000
    Text4 = "-----------------------------------------------------" & Chr$(13) & Chr$(10) & Text4
    For dbs = 0 To DbList.ListCount - 1
        ProgressBar1.Value = 0
        ProgressBar1.Max = cn.rdoTables.Count
        DoEvents
        cn1.Connect = "uid=sa;pwd=" & PassToPass & ";server=" & Text2 & ";driver={SQL Server};database=" & DbList.List(dbs) & ";DSN='';"
        cn1.CursorDriver = rdUseOdbc
        cn1.EstablishConnection rdDriverNoPrompt
        cn1.QueryTimeout = 3000
        cn1.rdoTables.Refresh
        found = False

        For Each TbSet In cn.rdoTables
            Set cpw = cn.CreateQuery("", "EXEC sp_tables " & TbSet.Name)
            Set tb = cpw.OpenResultset(2)
            If UCase$(TbSet.Type) = "TABLE" And UCase$(tb!table_type) = "TABLE" Then
                For Each TempTable In cn1.rdoTables
                    errorstring = ""
                    If UCase$(TempTable.Type) = "TABLE" Then
                        If UCase$(TbSet.Name) = UCase$(TempTable.Name) Then
                            found = True
                            For i = 0 To TbSet.rdoColumns.Count - 1
                                ColFound = False
                                For j = 0 To TempTable.rdoColumns.Count - 1
                                    DoEvents
                                    If UCase$(TbSet.rdoColumns(i).Name) = UCase$(TempTable.rdoColumns(j).Name) Then
                                        ColFound = True
                                        Exit For
                                    End If
                                Next j
                                If ColFound = False Then
                                    AddingOneColumn cn, cn1, TbSet, TempTable, errorstring, TbSet.rdoColumns(i).Name
                                    DoEvents
                                End If
                            Next i
                            If errorstring <> "" Then
                                Text4 = TempTable.Name & errorstring & Chr$(13) & Chr$(10) & Text4
                            End If
                            Exit For
                        End If
                    End If
                Next TempTable
            End If
            If found = False And UCase$(tb!table_type) = "TABLE" Then
                tmp = "cn.CreateQuery "
                AddTable cn, cn1, TbSet, TempTable
                Text4 = "<<< " & TbSet.Name & " Added To Original Database >>>" & Chr$(13) & Chr$(10) & Text4
            End If
            found = False
            Text4.Refresh
            ProgressBar1.Value = ProgressBar1.Value + 1
            DoEvents
            tb.Close
        Next TbSet
        StoredProcedures cn1, errorstring
        Text4 = errorstring & Chr$(13) & Chr$(10) & Text4
        Text4 = "  检查结果显示；安装的数据库是： " & DbList.List(dbs) & Chr$(13) & Chr$(10) & Text4
        DoEvents
        cn1.Close
    Next dbs
    Screen.MousePointer = 0
Bye:

Exit Sub

End Sub

Private Sub StoredProc_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then
        KeyAscii = 0
        SendKeys "{TAB}"
    End If

End Sub

Private Sub StoredProcedures(cnDest As rdoConnection, errorstring As String)

  Dim DestTb As rdoResultset
  Dim DestCpw As rdoQuery
  Dim DestTb1 As rdoResultset
  Dim DestCpw1 As rdoQuery
  Dim TextLine As String
  Dim sql As String
  Dim mysql As String
  Dim tb As rdoResultset
  Dim PrName As String
  Dim MyName As String

    On Error GoTo StoredProcedures_Error

    On Error Resume Next
        sql = ""
        Close #1
        Open Trim(Text1) For Input As #1
        Do While Not EOF(1)
            Line Input #1, TextLine
            If InStr(1, UCase$(TextLine), "CREATE PROCEDURE") Then
                cnDest.BeginTrans
                MyName = Trim$(Mid$(TextLine, 17))
                If InStr(1, UCase$(MyName), " ") <> 0 Then
                    PrName = Trim$(Mid$(MyName, 1, InStr(1, UCase$(MyName), " ") - 1))
                  Else
                    PrName = MyName
                End If
                Set DestCpw = cnDest.CreateQuery("", "select * from sysobjects where  name='" & PrName & "' and OBJECTPROPERTY(id, N'IsProcedure') = 1")
                Set DestTb = DestCpw.OpenResultset(2)
                If Not (DestTb.EOF And DestTb.BOF) Then
                    cnDest.Execute "drop procedure [dbo].[" & PrName & "]"
                End If

                sql = TextLine & Chr$(13) & Chr$(10)
                Do While Not (InStr(1, UCase$(TextLine), "GO") > 0)
                    If Not EOF(1) Then
                        Line Input #1, TextLine
                        sql = sql & TextLine & Chr$(13) & Chr$(10)
                      Else
                        Exit Do
                    End If
                Loop
                If InStr(1, sql, "GO") > 0 Then
                    sql = Mid$(sql, 1, InStr(1, sql, "GO") - 1)
                End If
                sql = Replace(sql, Chr$(34), "'")
                Set tb = cnDest.OpenResultset(Trim$(sql), 2, rdConcurRowVer)
                sql = ""
                cnDest.CommitTrans
                errorstring = errorstring & CheckPro(PrName, cnDest.Connect, "S")
            End If
        Loop

    On Error GoTo 0

Exit Sub

StoredProcedures_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure StoredProcedures of Form Form1"

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then
        KeyAscii = 0
        SendKeys "{TAB}"
    End If

End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then
        KeyAscii = 0
        SendKeys "{TAB}"
    End If

End Sub

Private Sub Text2_LostFocus()

  Dim tb As rdoResultset
  Dim cpw As rdoQuery
  Dim cn As New rdoConnection
  Dim cnf As New rdoConnection
  Dim tbf As rdoResultset
  Dim found As Boolean
  Dim sql As String

    DbList1.Clear
    DbList.Clear
    PassToPass = ""
    On Error GoTo ErrorinIt
TryAgain:

    If Len(Trim$(Text2)) = 0 Then
        Exit Sub
    End If

    cn.Connect = "uid=sa;pwd=" & PassToPass & ";server=" & Text2 & ";driver={SQL Server};database=Master;DSN='';"
    cn.CursorDriver = rdUseOdbc
    cn.EstablishConnection rdDriverNoPrompt

    Set cpw = cn.CreateQuery("", "Use master select * from sysdatabases ")
    Set tb = cpw.OpenResultset(2)
    Do While Not tb.EOF

        cnf.Connect = "uid=sa;pwd=" & PassToPass & ";server=" & Text2 & ";driver={SQL Server};database=" & tb!Name & ";DSN='';"
        cnf.CursorDriver = rdUseOdbc
        cnf.EstablishConnection rdDriverNoPrompt

        DbList1.AddItem tb!Name
        tb.MoveNext
        cnf.Close

    Loop
    tb.Close
    cn.Close
Byebye:

Exit Sub

ErrorinIt:
    If PassToPass <> "" Then
        PassToPass = ""
        Resume TryAgain
      Else
        Resume Byebye
    End If

End Sub

Private Sub TriggerCheck_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then
        KeyAscii = 0
        SendKeys "{TAB}"
    End If

End Sub

Private Sub Triggers(cnDest As rdoConnection, errorstring As String)

  Dim DestTb As rdoResultset
  Dim DestCpw As rdoQuery
  Dim TextLine As String
  Dim sql As String
  Dim tb As rdoResultset
  Dim TrName As String
  Dim MyName As String

    On Error GoTo Triggers_Error

    On Error Resume Next
        sql = ""
        Close #1
        Open Trim(Text1) For Input As #1
        Do While Not EOF(1)
            Line Input #1, TextLine
            If InStr(1, UCase$(TextLine), "CREATE TRIGGER") Then
                sql = TextLine & Chr$(13) & Chr$(10)
                cnDest.BeginTrans
                MyName = Trim$(Mid$(TextLine, 15))
                If InStr(1, UCase$(MyName), " ") <> 0 Then
                    TrName = Trim$(Mid$(MyName, 1, InStr(1, UCase$(MyName), " ") - 1))
                  Else
                    TrName = MyName
                End If
                Set DestCpw = cnDest.CreateQuery("", "select * from sysobjects where  name='" & TrName & "' and OBJECTPROPERTY(id, N'IsTrigger') = 1")
                Set DestTb = DestCpw.OpenResultset(2)
                If Not (DestTb.EOF And DestTb.BOF) Then
                    cnDest.Execute "drop trigger [dbo].[" & TrName & "]"
                End If
                Do While Not (InStr(1, UCase$(TextLine), "GO") > 0)
                    If Not EOF(1) Then
                        Line Input #1, TextLine
                        sql = sql & TextLine & Chr$(13) & Chr$(10)
                      Else
                        Exit Do
                    End If
                Loop
                If InStr(1, sql, "GO") > 0 Then
                    sql = Mid$(sql, 1, InStr(1, sql, "GO") - 1)
                End If
                sql = Replace(sql, Chr$(34), "'")
                Set tb = cnDest.OpenResultset(sql, 2, rdConcurRowVer)
                sql = ""
                cnDest.CommitTrans
                errorstring = errorstring & CheckPro(TrName, cnDest.Connect, "T")
            End If
        Loop

    On Error GoTo 0

Exit Sub

Triggers_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Triggers of Form Form1"

End Sub