📄 dbchecker.frm
字号:
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type : " & tb!type_name & "(" & tb!Precision & ") " & AcceptNulls & " Added In " & TbName
End Select
Exit Do
End If
tb.MoveNext
Loop
On Error GoTo 0
Exit Sub
AddingOneColumn_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddingOneColumn of Form Form1"
End Sub
Private Sub AddTable(cnSource As rdoConnection, cnDestination As rdoConnection, Sourcetb As rdoTable, DestinationTb As rdoTable)
Dim i As Integer
Dim tmp As String
Dim cpw As rdoQuery
Dim tb As rdoResultset
Dim AcceptNulls As String
Dim DefaultCol As String
On Error GoTo AddTable_Error
'------------------
Set cpw = cnSource.CreateQuery("", "exec sp_columns @table_name='" & Sourcetb.Name & "'")
Set tb = cpw.OpenResultset(2)
tmp = "Create Table " & Sourcetb.Name & " ( "
Do While Not tb.EOF
If Val(tb!nullable) = 1 Then
AcceptNulls = "Null"
Else
AcceptNulls = "Not Null"
End If
If Not IsNull(tb!COLUMN_DEF) Then
DefaultCol = " Default " & tb!COLUMN_DEF
Else
DefaultCol = ""
End If
Select Case LCase$(Trim$(tb!type_name))
Case "numeric() identity"
tmp = tmp & tb!COLUMN_NAME & " " & Left$(tb!type_name, InStr(tb!type_name, "(") - 1) & "(" & tb!Precision & "," & tb!Scale & ") " & " identity " & AcceptNulls & " " & DefaultCol
Case "decimal() identity"
tmp = tmp & tb!COLUMN_NAME & " " & Left$(tb!type_name, InStr(tb!type_name, "(") - 1) & "(" & tb!Precision & "," & tb!Scale & ") " & " identity " & AcceptNulls & " " & DefaultCol
Case "numeric"
tmp = tmp & tb!COLUMN_NAME & " " & tb!type_name & "(" & tb!Precision & "," & tb!Scale & ") " & AcceptNulls & " " & DefaultCol
Case "datetime", "bit", "int", "smallint"
tmp = tmp & tb!COLUMN_NAME & " " & tb!type_name & " " & AcceptNulls & " " & DefaultCol
Case "real", "text"
tmp = tmp & tb!COLUMN_NAME & " " & tb!type_name & " " & AcceptNulls & " " & DefaultCol
Case Else
tmp = tmp & tb!COLUMN_NAME & " " & tb!type_name & "(" & tb!Precision & ") " & AcceptNulls & " " & DefaultCol
End Select
tmp = tmp & ","
tb.MoveNext
Loop
tmp = Left$(tmp, Len(tmp) - 1) & ")"
cnDestination.Execute tmp
On Error GoTo 0
Exit Sub
AddTable_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddTable of Form Form1"
End Sub
Private Sub BrowseBtn_Click()
CD1.InitDir = "C:\"
CD1.Filter = "Script Files (*.sql)|*.sql"
CD1.FilterIndex = 1
CD1.ShowOpen
If CD1.FileTitle <> "" Then
Text1 = CD1.FileName
End If
End Sub
Private Sub CheckDefaults(cnSource As rdoConnection, cnDest As rdoConnection, TbName As String, ColumnName As String, errorstring As String)
Dim cpw As rdoQuery
Dim tb As rdoResultset
Dim cpw1 As rdoQuery
Dim tb1 As rdoResultset
On Error GoTo CheckDefaults_Error
Set cpw = cnSource.CreateQuery("", "exec sp_columns @table_name='" & TbName & "',@column_name='" & ColumnName & "'")
Set tb = cpw.OpenResultset(2)
Set cpw1 = cnDest.CreateQuery("", "exec sp_columns @table_name='" & TbName & "',@column_name='" & ColumnName & "'")
Set tb1 = cpw1.OpenResultset(2)
If Not (tb.EOF And tb.BOF) Then
If Not (tb1.EOF And tb1.BOF) Then
If Not IsNull(tb!COLUMN_DEF) Then
If Not IsNull(tb1!COLUMN_DEF) Then
If tb!COLUMN_DEF <> tb1!COLUMN_DEF Then
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & ColumnName & " : Different Defaults"
End If
Else
cnDest.Execute "ALTER TABLE " & TbName & " WITH NOCHECK add CONSTRAINT [DF_" & TbName & "_" & tb!COLUMN_NAME & "] DEFAULT " & tb!COLUMN_DEF & " FOR [" & tb!COLUMN_NAME & "] "
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Default: " & tb!COLUMN_DEF & " Added In " & TbName
End If
Else
If Not IsNull(tb1!COLUMN_DEF) Then
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & ColumnName & " : No Default For source"
End If
End If
End If
End If
On Error GoTo 0
Exit Sub
CheckDefaults_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CheckDefaults of Form Form1"
End Sub
Private Sub checkingIndexes(cnSource As rdoConnection, cnDestination As rdoConnection, Sourcetb As rdoTable, DestinationTb As rdoTable, errorstring As String, errOld As String)
Dim sql As String
Dim SrcCpw As rdoQuery
Dim SrcTb As rdoResultset
Dim DestCpw As rdoQuery
Dim DestTb As rdoResultset
Dim TextLine As String
Dim tb As rdoResultset
Dim Done As Boolean
On Error GoTo checkingIndexes_Error
'-------------------
On Error Resume Next
Done = False
sql = "SELECT TABLE_NAME = sysobjects.name,"
sql = sql & "INDEX_NAME = sysindexes.name, INDEX_ID = indid "
sql = sql & "FROM sysindexes INNER JOIN sysobjects ON sysobjects.id = sysindexes.id "
sql = sql & "Where sysobjects.Name = "
Set SrcCpw = cnSource.CreateQuery("", sql & "'" & Trim$(Sourcetb.Name) & "'")
Set SrcTb = SrcCpw.OpenResultset(2)
If SrcTb.RowCount <> 0 Then
Do While Not SrcTb.EOF
Set DestCpw = cnDestination.CreateQuery("", sql & "'" & Trim$(Sourcetb.Name) & "' and sysindexes.name= '" & Trim$(SrcTb!INDEX_NAME) & "'")
Set DestTb = DestCpw.OpenResultset(2)
If DestTb.RowCount = 0 Then
If errOld = "" Then
errorstring = Chr$(13) & Chr$(10) & Chr$(9) & Sourcetb.Name & " : " & SrcTb!INDEX_NAME & " Index Not Found "
Else
errorstring = Chr$(13) & Chr$(10) & SrcTb!INDEX_NAME & " Index Not Found "
End If
Close #1
Open Trim(Text1) For Input As #1
sql = ""
Do While Not EOF(1)
Line Input #1, TextLine
If InStr(1, UCase$(TextLine), "INDEX") > 0 And InStr(1, UCase$(TextLine), UCase$(Sourcetb.Name)) > 0 And InStr(1, UCase$(TextLine), UCase$(SrcTb!INDEX_NAME)) > 0 Then
Do While Not (InStr(1, UCase$(TextLine), "GO") > 0)
sql = sql & " " & TextLine
Line Input #1, TextLine
Loop
Set tb = cnDestination.OpenResultset(sql, 2, rdConcurRowVer) ', rdAsyncEnable
Done = True
If InStr(1, UCase$(TextLine), "GO") > 0 Then
sql = ""
'------------
End If
End If
Loop
If Not Done Then
Close #1
Open Trim(Text1) For Input As #1
sql = ""
Do While Not EOF(1)
Line Input #1, TextLine
If InStr(1, UCase$(TextLine), "ALTER TABLE") > 0 And InStr(1, UCase$(TextLine), UCase$(Sourcetb.Name)) > 0 Then
sql = TextLine
If Not EOF(1) Then
Line Input #1, TextLine
If InStr(1, UCase$(TextLine), UCase$(SrcTb!INDEX_NAME)) > 0 Then
Do While Not (InStr(1, UCase$(TextLine), "GO") > 0)
sql = sql & " " & TextLine
Line Input #1, TextLine
Loop
Set tb = cnDestination.OpenResultset(sql, 2, rdConcurRowVer) ', rdAsyncEnable
Done = True
If InStr(1, UCase$(TextLine), "GO") > 0 Then
Exit Do
End If
End If
End If
End If
Loop
End If
End If
SrcTb.MoveNext
Loop
End If
On Error GoTo 0
Exit Sub
checkingIndexes_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure checkingIndexes of Form Form1"
End Sub
Private Function CheckPro(PrName As String, ConString As String, MyType As String) As String
Dim Con1 As New rdoConnection
Dim DestCpw1 As rdoQuery
Dim DestTb1 As rdoResultset
On Error GoTo CheckPro_Error
Con1.Connect = ConString
Con1.CursorDriver = rdUseOdbc
Con1.EstablishConnection rdDriverNoPrompt
If MyType = "S" Then
Set DestCpw1 = Con1.CreateQuery("", "select * from sysobjects where name='" & PrName & "' and OBJECTPROPERTY(id, N'IsProcedure') = 1")
Set DestTb1 = DestCpw1.OpenResultset(2)
If (DestTb1.EOF And DestTb1.BOF) Then
CheckPro = Chr$(13) & Chr$(10) & Chr$(9) & " Could Not add Stored Procedure: " & PrName
End If
Else
Set DestCpw1 = Con1.CreateQuery("", "select * from sysobjects where name='" & PrName & "' and OBJECTPROPERTY(id, N'IsTrigger') = 1")
Set DestTb1 = DestCpw1.OpenResultset(2)
If (DestTb1.EOF And DestTb1.BOF) Then
CheckPro = Chr$(13) & Chr$(10) & Chr$(9) & " Could Not add Trigger: " & PrName
End If
End If
Con1.Close
On Error GoTo 0
Exit Function
CheckPro_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CheckPro of Form Form1"
End Function
Private Sub ColDefaults(cn1 As rdoConnection, TbName As String, ColName As String, colType As String, errorstring As String)
Dim cpw1 As rdoQuery
Dim tb1 As rdoResultset
On Error GoTo ColDefaults_Error
Select Case LCase$(Trim$(colType))
Case "2", "3", "4", "5", "6", "7", "8", "-2", "-3", "-4", "-5", "-6", "-7"
cn1.Execute "update " & TbName & " set " & ColName & " =0 where " & ColName & " is null"
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & " Added Default to " & ColName
Case "9", "10", "11"
cn1.Execute "update " & TbName & " set " & ColName & " =getdate() where " & ColName & " is null"
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & " Added Default to " & ColName
Case "12", "1", "-1"
cn1.Execute "update " & TbName & " set " & ColName & " =' ' where " & ColName & " is null"
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & " Added Default to " & ColName
End Select
On Error GoTo 0
Exit Sub
ColDefaults_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ColDefaults of Form Form1"
End Sub
Private Sub cmdDatabaseName_Click()
Static Name As String
Name = InputBox$("请输入数据库文件名", "操作提示", Name)
DbList.AddItem Name
End Sub
Private Sub cmdSqlFile_Click()
CD1.FileName = App.Path & "\TeleInfo.sql"
CD1.FilterIndex = 1
Text1 = CD1.FileName
End Sub
Private Sub Command2_Click()
passedTesting = False
If QuickDbCheck.Value = 1 Then
QuickDbChecker
Else
NameCheck
End If
' MsgBox "数据库安装成功!", vbInformation
End Sub
Private Sub DbDrive_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
SendKeys "{TAB}"
End If
End Sub
Private Sub DbList1_DblClick()
AddDb_Click
End Sub
Private Sub DbList_DblClick()
DelDb_Click
End Sub
Private Sub Defaults_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
SendKeys "{TAB}"
End If
End Sub
Private Sub DelDb_Click()
If DbList.ListIndex = -1 Then
Exit Sub '>---> Bottom
End If
DbList1.AddItem DbList.List(DbList.ListIndex)
DbList.RemoveItem DbList.ListIndex
End Sub
Private Sub DeleteDbs_Click()
Dim i As Integer
For i = DbList.ListCount - 1 To 0 Step -1
DbList1.AddItem DbList.List(i)
DbList.RemoveItem i
Next i
End Sub
Private Sub DeletePrimaryKeys(cn1 As rdoConnection, tablename As String)
Dim cpw As rdoQuery
Dim tb As rdoResultset
Dim TbName As String
Dim colType As String
Dim AcceptNulls As String
Dim j As Integer, K As Integer
'---------------------
On Error GoTo ERRORINDELETEpRIMARYkEY
Set cpw = cn1.CreateQuery("", "exec sp_columns @table_name='" & tablename & "'")
Set tb = cpw.OpenResultset(2)
Do While Not tb.EOF
If LCase$(Trim$(tb!type_name)) = "numeric() identity" Then
K = 1
cn1.Execute "Alter table " & tablename & " drop constraint pk_" & tablename
K = 2
cn1.Execute "Alter table " & tablename & " drop column " & tb!COLUMN_NAME
cn1.rdoTables.Refresh
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -