📄 form_newdatabase.frm
字号:
VERSION 5.00
Begin VB.Form Frm_Newdatabase
BorderStyle = 1 'Fixed Single
Caption = "新建帐套"
ClientHeight = 3330
ClientLeft = 3300
ClientTop = 2655
ClientWidth = 5085
HelpContextID = 1012
Icon = "Form_NewDataBase.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3330
ScaleWidth = 5085
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command2
Height = 285
Left = 4590
Picture = "Form_NewDataBase.frx":0ECA
Style = 1 'Graphical
TabIndex = 19
Top = 1170
Width = 315
End
Begin VB.TextBox Text1
Height = 270
Index = 3
Left = 1410
Locked = -1 'True
TabIndex = 12
Top = 1170
Width = 3225
End
Begin VB.Frame Frame1
Caption = "数据库信息"
Height = 1725
Left = 150
TabIndex = 13
Top = 1470
Width = 4755
Begin VB.TextBox Text2
Height = 285
Index = 0
Left = 1380
TabIndex = 4
Top = 330
Width = 2505
End
Begin VB.TextBox Text2
Height = 285
IMEMode = 3 'DISABLE
Index = 1
Left = 1380
PasswordChar = "*"
TabIndex = 5
Top = 630
Width = 2505
End
Begin VB.TextBox Text2
Height = 285
Index = 2
Left = 1380
TabIndex = 6
Top = 930
Width = 2505
End
Begin VB.ComboBox Combo1
Height = 300
ItemData = "Form_NewDataBase.frx":11DC
Left = 1380
List = "Form_NewDataBase.frx":11E3
Style = 2 'Dropdown List
TabIndex = 7
Top = 1230
Width = 2505
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "用户名:"
Height = 180
Index = 0
Left = 360
TabIndex = 17
Top = 330
Width = 630
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "口令:"
Height = 180
Index = 1
Left = 360
TabIndex = 16
Top = 660
Width = 450
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "数据服务器:"
Height = 180
Index = 2
Left = 360
TabIndex = 15
Top = 960
Width = 990
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "数据库类型:"
Height = 180
Index = 3
Left = 360
TabIndex = 14
Top = 1290
Width = 990
End
End
Begin VB.CommandButton Cmd_Cancel
Caption = "取消(&C)"
Height = 315
Left = 3720
TabIndex = 3
Top = 780
Width = 1125
End
Begin VB.CommandButton Cmd_CreatNew
Caption = "确定(&O)"
Height = 315
Left = 3720
TabIndex = 2
Top = 150
Width = 1125
End
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 270
Index = 2
Left = 1410
TabIndex = 11
Top = 810
Width = 2085
End
Begin VB.TextBox Text1
Height = 270
Index = 1
Left = 1410
TabIndex = 1
Top = 480
Width = 2085
End
Begin VB.TextBox Text1
Height = 270
Index = 0
Left = 1410
TabIndex = 0
Top = 150
Width = 2085
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "库文件路径:"
Height = 180
Index = 3
Left = 240
TabIndex = 18
Top = 1170
Width = 990
End
Begin VB.Label Label1
Caption = "数据库名:"
Height = 225
Index = 2
Left = 270
TabIndex = 10
Top = 840
Width = 945
End
Begin VB.Label Label1
Caption = "帐套名:"
Height = 225
Index = 1
Left = 270
TabIndex = 9
Top = 510
Width = 945
End
Begin VB.Label Label1
Caption = "帐套编号:"
Height = 225
Index = 0
Left = 270
TabIndex = 8
Top = 180
Width = 945
End
End
Attribute VB_Name = "Frm_Newdatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Cmd_Cancel_Click()
Unload Me
End Sub
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
SendKeys "{Tab}", True
End If
End Sub
Private Function fun_PrepareCreateOK(sInfo As String) As Boolean
'检测新建数据库等各种条件是否成熟，sInfo 负责返回错误信息 by lg 2002-12-17
Dim sSql As String
Dim rs As New ADODB.Recordset
Dim sTmp As String
fun_PrepareCreateOK = False
If Trim(Text1(0).Text) = "" Then sTmp = "帐套编码不能为空！ ": Text1(0).SetFocus: GoTo errD
If Trim(Text1(1).Text) = "" Then sTmp = "帐套名称不能为空！ ": Text1(1).SetFocus: GoTo errD
If Trim(Text1(2).Text) = "" Then sTmp = "数据库名不能为空！ ": Text1(2).SetFocus: GoTo errD
If IsNumeric(Text1(2).Text) Then sTmp = "数据库名不能为数值！ ": Text1(2).SetFocus: GoTo errD
If Trim(Text1(3).Text) = "" Then
sTmp = "数据库保存路径不能为空！ ": Text1(3).SetFocus: GoTo errD
Else
If Dir(Trim(Text1(3).Text), vbDirectory) = "" Then sTmp = "数据库保存路径不存在!": GoTo errD
End If
If Trim(Text2(0).Text) = "" Then sTmp = "数据库用户不能为空！ ": Text2(0).SetFocus: GoTo errD
If Trim(Text2(2).Text) = "" Then sTmp = "数据服务器不能为空！ ": Text2(2).SetFocus: GoTo errD
If Cw_DataEnvi.Connection2.state = 1 Then Cw_DataEnvi.Connection2.Close
Cw_DataEnvi.Connection2.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & Trim(Text2(2).Text) & "; Initial Catalog=Master;", Trim(Text2(0).Text), Trim(Text2(1).Text)
sSql = "SELECT * FROM EboSys..Ebo_DataBases WHERE Number='" & Trim(Text1(0).Text) & "'"
Set rs = Cw_DataEnvi.Connection2.Execute(sSql)
If Not rs.EOF Then
sTmp = "帐套编码不能重复！": GoTo errD
End If
If rs.state = 1 Then rs.Close
sSql = "SELECT * FROM EboSys..Ebo_DataBases WHERE CountingRoomName='" & Trim(Text1(1).Text) & "'"
Set rs = Cw_DataEnvi.Connection2.Execute(sSql)
If Not rs.EOF Then
sTmp = "帐套名称不能重复！": GoTo errD
End If
If rs.state = 1 Then rs.Close
sSql = "SELECT * FROM EboSys..Ebo_DataBases WHERE DataBasesName='" & Trim(Text1(2).Text) & "'"
Set rs = Cw_DataEnvi.Connection2.Execute(sSql)
If Not rs.EOF Then
sTmp = "数据库名不能重复！": GoTo errD
End If
If Dir(App.Path & "\" & DBphyFileName & ".bak") = "" Then
sTmp = "数据源文文件不存在!(" & App.Path & "\" & DBphyFileName & ".bak)": GoTo errD
End If
fun_PrepareCreateOK = True
errD:
If Trim(sTmp) = "" Then sTmp = "未知错误!"
sInfo = sTmp
End Function
Private Sub sub_CreatNewDB()
'新建数据库帐套 lg 2002-12-17
Dim sInfo As String
Dim sSql As String, NewDBName As String, NewDBPath As String
Dim BakDBName As String, BakDBFileName As String ', BakDBPath As String
Dim CountingRoomName As String, Number As String
Dim ServerName As String, DBType As String
Dim Data_Error As Integer
Dim Data_ErrorName As String
Dim aStr As String
On Error GoTo Exit_error
setStatusBar "正在检测数据库信息...", False
'测试连接
If Conn_System1.state = 1 Then Conn_System1.Close
Conn_System1.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & Trim(Text2(2).Text) & "; Initial Catalog=EboSys;", Trim(Text2(0).Text), Trim(Text2(1).Text)
If Not fun_PrepareCreateOK(sInfo) Then MsgBox sInfo, vbCritical: Exit Sub
setStatusBar "", True
'准备变量
NewDBName = Trim(Text1(2).Text): NewDBPath = Trim(Text1(3).Text): BakDBName = DBphyFileName
BakDBFileName = DBlogicFileName: CountingRoomName = Trim(Text1(1).Text)
Number = Trim(Text1(0).Text): ServerName = Trim(Text2(2).Text): DBType = Trim(Combo1.Text)
Me.MousePointer = 12
setStatusBar "正在创建帐套...", False
If Cw_DataEnvi.Connection2.state = 1 Then Cw_DataEnvi.Connection2.Close
Cw_DataEnvi.Connection2.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & Trim(Text2(2).Text) & "; Initial Catalog=EboSys;", Trim(Text2(0).Text), Trim(Text2(1).Text)
'-----------------
'恢复数据库(新建帐套)
sSql = "RESTORE DATABASE " & NewDBName & " FROM DISK = '" & App.Path & "\" & BakDBName & ".bak' " & Chr(10) _
& " WITH MOVE '" & BakDBFileName & "_data'" & " TO '" & NewDBPath & "\" & NewDBName & ".mdf' ," & Chr(10) _
& " MOVE '" & BakDBFileName & "_log'" & " TO '" & NewDBPath & "\" & NewDBName & ".ldf'"
Call Cw_DataEnvi.Connection2.Execute(sSql)
setStatusBar "", True
Me.MousePointer = 0
'填写登记表
sSql = "INSERT INTO EboSys..Ebo_DataBases(DataBasesName, Number, CountingRoomName, NewDate, ServerName, DatabaseType, YNuse, CoName, qsqj,Address,phone)" _
& " VALUES('" & NewDBName & "','" & Number & "','" & CountingRoomName & "',GETDATE(),'" & ServerName & "','" & DBType & "','0','江苏南通倪老师电脑科技','1','江苏省如东县双甸镇石甸大桥西48米','13301481112') "
Call Cw_DataEnvi.Connection2.Execute(sSql)
'善后
If Conn_System1.state = 1 Then Conn_System1.Close: Set Conn_System1 = Nothing
If Cw_DataEnvi.Connection2.state = 1 Then Cw_DataEnvi.Connection2.Close
Form_main.Form_Load
Unload Me
Exit Sub
'-----------------
Exit_error:
setStatusBar "", True
Me.MousePointer = 0
Select Case Err.Number
Case -2147467259
MsgBox "数据服务器错误！", 16
Case -2147217843
MsgBox "用户名或口令错误！", 16
Case Else
MsgBox Err.Description & "(" & Err.Number & ")", 16
End Select
End Sub
Private Sub Cmd_CreatNew_Click()
Call sub_CreatNewDB
End Sub
Private Sub Command2_Click()
Frm_Path.Show 1
If PathStr <> "" Then Text1(3).Text = PathStr
End Sub
Private Sub Form_Load()
Dim Str As String
Combo1.ListIndex = 0
' TextFile
sub_iniLogInfo
End Sub
Private Sub sub_iniLogInfo()
On Error GoTo err_exit
Text2(2).Text = Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "ServerName"))
If Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "UserID")) = "" Then
Text2(0).Text = "sa"
Else
Text2(0).Text = Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "UserID"))
End If
If Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Password")) <> "" Then
Text2(1).Text = Mmjm2(Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Password")))
End If
Text1(2).Text = "EboSys" & Year(Date)
Text1(3).Text = App.Path
Exit Sub
err_exit:
Text2(0).Enabled = True
End Sub
Private Function Mmjm2(Srmm As String) As String '密码解密模块
Dim Zfcte As Integer
Mmjm2 = ""
For Jsqte = 1 To Int(Len(Srmm) / 3)
Zfcte = Val(Mid(Srmm, (Jsqte - 1) * 3 + 1, 3)) - Int(Len(Srmm) / 3) - Jsqte
Mmjm2 = Mmjm2 + Chr(Zfcte)
Next Jsqte
End Function
Private Sub Text1_Change(Index As Integer)
If Index = 3 Then
If Len(Trim(Text1(3).Text)) = 3 Then Text1(3).Text = Mid(Trim(Text1(3)), 1, 2)
End If
End Sub
Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
SendKeys "{Tab}", True
End If
End Sub
Private Sub Text2_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
SendKeys "{Tab}", True
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -