📄 dbchecker.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "SQL Server数据库安装程序"
ClientHeight = 4440
ClientLeft = 45
ClientTop = 330
ClientWidth = 7110
Icon = "DBChecker.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4440
ScaleWidth = 7110
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdDatabaseName
Caption = "Name"
Height = 285
Left = 2775
TabIndex = 24
ToolTipText = "输入数据库文件名到右边列表中"
Top = 1065
Width = 585
End
Begin VB.CommandButton cmdSqlFile
Caption = "SQL本地"
Height = 315
Left = 6015
TabIndex = 23
ToolTipText = "本文件夹以有的SQL数据库文件"
Top = 720
Width = 810
End
Begin VB.CheckBox QuickDbCheck
Caption = "快速安装"
Height = 315
Left = 5115
TabIndex = 22
Top = 1095
Value = 1 'Checked
Width = 1605
End
Begin VB.TextBox Text4
Height = 960
Left = 225
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 20
Top = 3270
Width = 6630
End
Begin VB.Frame Frame1
Caption = "选项"
Enabled = 0 'False
Height = 1140
Left = 5115
TabIndex = 19
Top = 1425
Width = 1755
Begin VB.CheckBox Defaults
Caption = "默认"
Enabled = 0 'False
Height = 255
Left = 105
TabIndex = 6
Top = 240
Width = 1365
End
Begin VB.CheckBox StoredProc
Caption = "存储过程"
Enabled = 0 'False
Height = 405
Left = 105
TabIndex = 7
Top = 435
Value = 1 'Checked
Width = 1545
End
Begin VB.CheckBox TriggerCheck
Caption = "触发器"
Enabled = 0 'False
Height = 255
Left = 105
TabIndex = 8
Top = 795
Width = 1605
End
End
Begin VB.TextBox DbDrive
Height = 285
Left = 4575
TabIndex = 3
Text = "C"
Top = 735
Width = 435
End
Begin VB.CommandButton AddDbs
Caption = ">>"
Height = 285
Left = 2775
TabIndex = 17
Top = 1965
Width = 585
End
Begin VB.CommandButton DeleteDbs
Caption = "<<"
Height = 285
Left = 2775
TabIndex = 16
Top = 2265
Width = 585
End
Begin VB.ListBox DbList1
Height = 1500
Left = 1125
TabIndex = 4
ToolTipText = "单一选择数据库，切记。"
Top = 1065
Width = 1605
End
Begin VB.CommandButton DelDb
Caption = "<"
Height = 285
Left = 2775
TabIndex = 15
Top = 1665
Width = 585
End
Begin VB.ListBox DbList
Height = 1500
Left = 3405
TabIndex = 5
Top = 1065
Width = 1605
End
Begin VB.CommandButton AddDb
Caption = ">"
Height = 285
Left = 2775
TabIndex = 14
ToolTipText = "选择左边数据库到右边列表中"
Top = 1365
Width = 585
End
Begin VB.CommandButton Command2
Caption = "安装数据库"
Height = 345
Left = 5385
TabIndex = 9
Top = 2670
Width = 1485
End
Begin VB.TextBox Text2
Height = 285
Left = 1125
TabIndex = 2
Text = "(local)"
Top = 735
Width = 1605
End
Begin VB.CommandButton BrowseBtn
Caption = "SQL文件"
Height = 315
Left = 5160
TabIndex = 1
ToolTipText = "查找SQL语句数据库安装文件"
Top = 720
Width = 810
End
Begin MSComDlg.CommonDialog CD1
Left = 360
Top = 4470
_ExtentX = 847
_ExtentY = 847
_Version = 393216
InitDir = "app.path"
End
Begin VB.TextBox Text1
Height = 510
Left = 1125
MultiLine = -1 'True
TabIndex = 0
Top = 135
Width = 5685
End
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 210
Left = 240
TabIndex = 10
Top = 2745
Width = 5115
_ExtentX = 9022
_ExtentY = 370
_Version = 393216
Appearance = 0
End
Begin VB.Label Label7
AutoSize = -1 'True
Caption = "数据库安装信息"
Height = 180
Left = 300
TabIndex = 21
Top = 3060
Width = 1260
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "临时驱动器"
Height = 180
Left = 3510
TabIndex = 18
Top = 780
Width = 900
End
Begin VB.Label Label4
Alignment = 1 'Right Justify
Caption = "数据库"
Height = 225
Left = -30
TabIndex = 13
Top = 1110
Width = 960
End
Begin VB.Label Label3
Alignment = 1 'Right Justify
Caption = "服务器"
Height = 225
Left = 0
TabIndex = 12
Top = 765
Width = 930
End
Begin VB.Label Label2
Caption = "文件位置"
Height = 225
Left = 225
TabIndex = 11
Top = 165
Width = 795
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private PassToPass As String
Private passedTesting As Boolean
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
"GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, _
lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, _
lpTotalNumberOfFreeBytes As Currency) As Long
Private Sub AddDb_Click()
If DbList1.ListIndex = -1 Then
Exit Sub
End If
If Trim$(DbList1.List(DbList1.ListIndex)) = "" Then
Exit Sub
End If
DbList.AddItem Trim$(DbList1.List(DbList1.ListIndex))
DbList1.RemoveItem DbList1.ListIndex
End Sub
Private Sub AddDbs_Click()
Dim i As Integer
For i = DbList1.ListCount - 1 To 0 Step -1
DbList.AddItem DbList1.List(i)
DbList1.RemoveItem i
Next i
End Sub
Private Sub AddDefaults_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
SendKeys "{TAB}"
End If
End Sub
Private Sub AddingColumns(cnSource As rdoConnection, cnDestination As rdoConnection, Sourcetb As rdoTable, DestinationTb As rdoTable, StartingRow As Integer, errorstring As String)
Dim cpw As rdoQuery
Dim tb As rdoResultset
Dim i As Integer
Dim TbName As String
Dim colType As String
Dim AcceptNulls As String
Dim ColDef As String
Dim j As Integer
Dim DefaultCol As String
On Error GoTo AddingColumns_Error
'---------------------
TbName = DestinationTb.Name
Set cpw = cnSource.CreateQuery("", "exec sp_columns @table_name='" & TbName & "'")
Set tb = cpw.OpenResultset(2)
For i = (Sourcetb.rdoColumns.Count - StartingRow + 1) To Sourcetb.rdoColumns.Count
tb.MoveFirst
Do While Not tb.EOF
If tb!ordinal_position = i Then
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"
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & "(" & tb!Precision & "," & tb!Scale & ") " & AcceptNulls & " " & DefaultCol
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type: " & tb!type_name & "(" & tb!Precision & "," & tb!Scale & ") " & AcceptNulls & " Added In " & TbName
Case "datetime", "bit", "int", "smallint", "real"
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & " " & AcceptNulls & " " & DefaultCol
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type: " & tb!type_name & " " & AcceptNulls & " Added In " & TbName
Case Else
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & "(" & tb!Precision & ") " & AcceptNulls & " " & DefaultCol
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
Next i
On Error GoTo 0
Exit Sub
AddingColumns_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddingColumns of Form Form1"
End Sub
Private Sub AddingOneColumn(cnSource As rdoConnection, cnDestination As rdoConnection, Sourcetb As rdoTable, DestinationTb As rdoTable, errorstring As String, ColName 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
Dim DefaultCol As String
Dim TSQL As String
On Error GoTo AddingOneColumn_Error
'---------------------
TbName = DestinationTb.Name
Set cpw = cnSource.CreateQuery("", "exec sp_columns @table_name='" & TbName & "'")
Set tb = cpw.OpenResultset(2)
Do While Not tb.EOF
If UCase$(tb!COLUMN_NAME) = UCase$(ColName) Then
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"
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & "(" & tb!Precision & "," & tb!Scale & ") " & AcceptNulls & " " & DefaultCol
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type: " & tb!type_name & "(" & tb!Precision & "," & tb!Scale & ") " & AcceptNulls & " Added In " & TbName
Case "datetime", "bit", "int", "smallint"
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & " " & AcceptNulls & " " & DefaultCol
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type: " & tb!type_name & " " & AcceptNulls & " Added In " & TbName
Case "numeric() identity"
TSQL = "ALTER TABLE " & TbName & " ADD PrimaryKey " & Left$(tb!type_name, InStr(tb!type_name, "(") - 1) & "(" & tb!Precision & "," & tb!Scale & ") " & " identity not for replication " & AcceptNulls & Chr$(13)
TSQL = TSQL & " ALTER TABLE [dbo].[" & TbName & "] WITH NOCHECK ADD CONSTRAINT [PK_" & TbName & "] PRIMARY KEY NONCLUSTERED ([PrimaryKey]) WITH FILLFACTOR = 90 ON [PRIMARY]"
cnDestination.Execute TSQL
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type: " & tb!type_name & "(" & tb!Precision & "," & tb!Scale & ") " & AcceptNulls & " Added In " & TbName
Case "real"
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & " " & AcceptNulls & " " & DefaultCol
errorstring = errorstring & Chr$(13) & Chr$(10) & Chr$(9) & tb!COLUMN_NAME & " Type: " & tb!type_name & " " & AcceptNulls & " Added In " & TbName
Case Else
cnDestination.Execute "ALTER TABLE " & TbName & " ADD " & tb!COLUMN_NAME & " " & tb!type_name & "(" & tb!Precision & ") " & AcceptNulls & " " & DefaultCol
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -