📄 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":038A
Style = 1 'Graphical
TabIndex = 19
Top = 1170
Width = 315
End
Begin VB.TextBox Text1
Height = 270
Index = 3
Left = 1410
Locked = -1 'True
TabIndex = 6
Top = 1170
Width = 3225
End
Begin VB.Frame Frame1
Caption = "数据库信息"
Height = 1725
Left = 150
TabIndex = 9
Top = 1470
Width = 4755
Begin VB.TextBox Text2
Height = 285
Index = 0
Left = 1380
TabIndex = 13
Top = 330
Width = 2505
End
Begin VB.TextBox Text2
Height = 285
IMEMode = 3 'DISABLE
Index = 1
Left = 1380
PasswordChar = "*"
TabIndex = 12
Top = 630
Width = 2505
End
Begin VB.TextBox Text2
Height = 285
Index = 2
Left = 1380
TabIndex = 11
Top = 930
Width = 2505
End
Begin VB.ComboBox Combo1
Height = 300
ItemData = "Form_NewDataBase.frx":069C
Left = 1380
List = "Form_NewDataBase.frx":06A3
Style = 2 'Dropdown List
TabIndex = 10
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 Command1
Caption = "取消&C"
Height = 315
Index = 1
Left = 3720
TabIndex = 8
Top = 780
Width = 1125
End
Begin VB.CommandButton Command1
Caption = "确定&D"
Height = 315
Index = 0
Left = 3720
TabIndex = 7
Top = 150
Width = 1125
End
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 270
Index = 2
Left = 1410
TabIndex = 5
Top = 810
Width = 2085
End
Begin VB.TextBox Text1
Height = 270
Index = 1
Left = 1410
TabIndex = 4
Top = 480
Width = 2085
End
Begin VB.TextBox Text1
Height = 270
Index = 0
Left = 1410
TabIndex = 3
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 = 2
Top = 840
Width = 945
End
Begin VB.Label Label1
Caption = "套帐名:"
Height = 225
Index = 1
Left = 270
TabIndex = 1
Top = 510
Width = 945
End
Begin VB.Label Label1
Caption = "套帐编号:"
Height = 225
Index = 0
Left = 270
TabIndex = 0
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 Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
SendKeys "{Tab}", True
End If
End Sub
Private Sub Command1_Click(Index As Integer)
If Index = 1 Then
Unload Me
Exit Sub
End If
If Trim(Text1(0).Text) = "" Then MsgBox "套帐编码不能为空！ ", 16: Text1(0).SetFocus: Exit Sub
If Trim(Text1(1).Text) = "" Then MsgBox "套帐名称不能为空！ ", 16: Text1(1).SetFocus: Exit Sub
If Trim(Text1(2).Text) = "" Then MsgBox "数据库名不能为空！ ", 16: Text1(2).SetFocus: Exit Sub
If IsNumeric(Text1(2).Text) Then MsgBox "数据库名不能为数值！ ", 16: Text1(2).SetFocus: Exit Sub
If Trim(Text2(0).Text) = "" Then MsgBox "数据库用户不能为空！ ", 16: Text2(0).SetFocus: Exit Sub
If Trim(Text2(2).Text) = "" Then MsgBox "数据服务器不能为空！ ", 16: Text2(2).SetFocus: Exit Sub
'--------------------------
Dim Data_Error As Integer
Dim Data_ErrorName As String
On Error GoTo Exit_error
Class.StatusBar "正在检测数据库信息...", 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=master;", Trim(Text2(0).Text), Trim(Text2(1).Text)
Class.StatusBar "", True
Me.MousePointer = 12
Class.StatusBar "正在创建套帐...", 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=master;", Trim(Text2(0).Text), Trim(Text2(1).Text)
'-----------------
Cw_DataEnvi.dbo_HD_AddDatabase Trim(Text1(2).Text), Trim(Text1(3).Text) _
, "Erp5Data", "Erp5Data", App.Path, Trim(Text1(1).Text), Trim(Text1(0).Text) _
, Trim(Text2(2).Text), Trim(Combo1.Text), Data_Error, Data_ErrorName
Class.StatusBar "", True
Me.MousePointer = 0
If Conn_System1.State = 1 Then Conn_System1.Close: Set Conn_System1 = Nothing
If Cw_DataEnvi.Connection2.State = 1 Then Cw_DataEnvi.Connection2.Close
Conn_System.Execute "update master.dbo.HDSystem_DataBases set CoName='南通易博科技资讯有限公司',YNuse='0' where DataBasesName='" & Text1(2).Text & "'"
If Data_Error = 1 Then
Form_main.Form_Load
MsgBox Data_ErrorName, 48
Unload Me
Else
Text1(2).Text = "EBO" & Year(Date) & Month(Date) & Day(Date) & Hour(Time) & Minute(Time) & Second(Time)
MsgBox Data_ErrorName, 16
End If
Exit Sub
'-----------------
Exit_error:
Class.StatusBar "", 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 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
Text1(2).Text = "EBO" & Year(Date) & Month(Date) & Day(Date) & Hour(Time) & Minute(Time) & Second(Time)
Text1(3).Text = App.Path
End Sub
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
Private Sub TextFile()
On Error Resume Next
Dim Fsote As Variant
Dim Tste As Variant
Dim Dqhs As Integer, Dqnr As String
Dim i As Integer
Set Fsote = CreateObject("Scripting.FileSystemObject")
Set Tste = Fsote.OpenTextFile(App.Path + "\System_Erp.txt", 1)
For i = 1 To 4
Dqnr = Trim(Tste.ReadLine)
If InStr(1, UCase(Dqnr), "SQLSERVER=") <> 0 Then
Text2(2).Text = Mid(Dqnr, InStr(1, UCase(Dqnr), "SQLSERVER=") + 10, Len(Dqnr))
End If
If InStr(1, UCase(Dqnr), "USERID=") <> 0 Then
Text2(0).Text = Mid(Dqnr, InStr(1, UCase(Dqnr), "USERID=") + 7, Len(Dqnr))
End If
Next i
Exit Sub
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -