📄 fmrnewaccont.frm
字号:
VERSION 5.00
Begin VB.Form frmNewAccount
BorderStyle = 1 'Fixed Single
Caption = "新建帐套"
ClientHeight = 4170
ClientLeft = 45
ClientTop = 330
ClientWidth = 6330
LinkTopic = "Form2"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4170
ScaleWidth = 6330
StartUpPosition = 1 '所有者中心
Begin VB.CheckBox chkOA
Caption = "Check1"
Height = 195
Left = 1800
TabIndex = 14
Top = 2700
Width = 195
End
Begin VB.TextBox txtCOName
Height = 330
Left = 1800
TabIndex = 11
Top = 2160
Width = 4035
End
Begin VB.TextBox txtAccountName
Height = 330
Left = 1800
TabIndex = 9
Top = 1713
Width = 4035
End
Begin VB.CommandButton cmdExit
Caption = "取消"
Height = 435
Left = 3540
TabIndex = 8
Top = 3060
Width = 1395
End
Begin VB.CommandButton cmdSelect
Caption = "连接"
Height = 435
Left = 1260
TabIndex = 7
Top = 3510
Width = 1395
End
Begin VB.TextBox txtDBName
Height = 330
Left = 1800
TabIndex = 2
Top = 1267
Width = 4035
End
Begin VB.TextBox txtAdminPassWord
Height = 330
Left = 1800
TabIndex = 1
Top = 821
Width = 4035
End
Begin VB.TextBox txtServerName
Height = 345
Left = 1800
TabIndex = 0
Top = 360
Width = 4035
End
Begin VB.CommandButton cmdNewAccount
Caption = "新建"
Height = 435
Left = 1260
TabIndex = 3
Top = 3060
Width = 1395
End
Begin VB.Label lblState
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000D&
Height = 375
Left = 270
TabIndex = 15
Top = 3690
Visible = 0 'False
Width = 5775
End
Begin VB.Label Label6
Caption = "是否使用OA:"
Height = 195
Left = 360
TabIndex = 13
Top = 2700
Width = 1395
End
Begin VB.Label Label5
Caption = "公司名称:"
Height = 195
Left = 360
TabIndex = 12
Top = 2244
Width = 1305
End
Begin VB.Label Label4
Caption = "用户帐套名称:"
Height = 195
Left = 360
TabIndex = 10
Top = 1788
Width = 1305
End
Begin VB.Label Label3
Caption = "SQL 数据库名称:"
Height = 195
Left = 360
TabIndex = 6
Top = 1332
Width = 1305
End
Begin VB.Label Label2
Caption = "SQL 管理员密码:"
Height = 195
Left = 360
TabIndex = 5
Top = 876
Width = 1395
End
Begin VB.Label Label1
Caption = "SQL 服务器名称:"
Height = 195
Left = 360
TabIndex = 4
Top = 420
Width = 1395
End
End
Attribute VB_Name = "frmNewAccount"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public linkString1 As String, cn As New Connection, LocalCN As New ADODB.Connection
Public Function ExecuteScript(txtFileName As String) As Integer
On Error GoTo Err_ExecuteScript
ExecuteScript = 1
Dim NextLine As String, ScriptSql As String
Close 1
ScriptSql = ""
Open txtFileName For Input As 1
Do Until EOF(1)
Line Input #1, NextLine
If NextLine <> "GO" Then
ScriptSql = ScriptSql + NextLine + Chr(13) + Chr(10)
Else
DoEvents
If DBCN(CreateCNString) = 1 Then
cn.CommandTimeout = 0
cn.Execute ScriptSql 'GetSQlScript(App.Path & "\GalaxyTab.txt")
End If
ScriptSql = ""
End If
Loop
ExecuteScript = 0
Exit Function
Err_ExecuteScript:
MisMsg "ExecuteScript Error:" & Err.Description
ExecuteScript = 1
Exit Function
End Function
Private Function CreateDBString() As String
On Error GoTo Err_CreateDBString
Dim strLink As String
strLink = "Provider=SQLOLEDB.1;"
If Trim(Me.txtAdminPassWord.Text) <> "" Then
strLink = strLink & "Password=" & Trim(Me.txtAdminPassWord.Text) & ""
End If
strLink = strLink & ";Persist Security Info=False;User ID=sa;Data Source=" & Trim(Me.txtServerName.Text) & ""
CreateDBString = strLink
Exit Function
Err_CreateDBString:
CreateDBString = ""
MisMsg "CreateDBString Error:" & Err.Description
Exit Function
End Function
Private Function CreateCNString() As String
On Error GoTo Err_CreateCNString
Dim strLink As String
strLink = "Provider=SQLOLEDB.1;"
If Trim(Me.txtAdminPassWord.Text) <> "" Then
strLink = strLink & "Password=" & Trim(Me.txtAdminPassWord.Text) & ""
End If
strLink = strLink & ";Persist Security Info=False;User ID=sa;Initial Catalog=" & Trim(Me.txtDBName.Text) & ";Data Source=" & Trim(Me.txtServerName.Text) & ""
CreateCNString = strLink
Exit Function
Err_CreateCNString:
CreateCNString = ""
MisMsg "CreateCNString Error:" & Err.Description
Exit Function
End Function
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub cmdNewAccount_Click()
Dim rstAccount As Recordset, i As Integer
Me.MousePointer = 11
If DBCN(CreateDBString) = 1 Then
On Error GoTo Err_CreateBD
Me.lblState.Visible = True
Me.lblState.Caption = " 正在创建数据库……"
cn.Execute "Create Database " & Trim(Me.txtDBName.Text)
Me.lblState.Caption = " 正在创建表……"
If ExecuteScript(App.Path & "\GalaxyTab.txt") = 1 Then
GoTo Err_CreateBD
End If
Me.lblState.Caption = " 正在创建视图……"
If ExecuteScript(App.Path & "\GalaxyView.txt") = 1 Then
GoTo Err_CreateBD
End If
Me.lblState.Caption = " 正在创建存储过程……"
If ExecuteScript(App.Path & "\GalaxyStored.txt") = 1 Then
GoTo Err_CreateBD
End If
Me.lblState.Caption = " 正在初始化数据……"
If ExecuteScript(App.Path & "\GalaxyData.txt") = 1 Then
GoTo Err_CreateBD
End If
If Dir(App.Path & "\" & Trim(Me.txtDBName.Text) & ".Mdb") = Trim(Me.txtDBName.Text) & ".Mdb" Then
Kill App.Path & "\" & Trim(Me.txtDBName.Text) & ".Mdb"
End If
FileCopy App.Path & "\MainGalaxy.Mdb", App.Path & "\" & Trim(Me.txtDBName.Text) & ".Mdb"
'Me.lblState.Caption = " 正在创建数据库……"
Set rstAccount = New Recordset
rstAccount.Open "Select * From AccountName where AccountID='" & Me.txtDBName.Text & "'", GetCNMain, adOpenStatic, adLockOptimistic
With rstAccount
If .EOF Then
.AddNew
![AccountID] = Me.txtDBName.Text & ""
![ServerName] = Me.txtServerName.Text & ""
![Password] = Me.txtAdminPassWord.Text & ""
![Description] = Me.txtAccountName.Text & ""
![company] = Me.txtCOName.Text & ""
![IsOA] = Me.chkOA.Value
.Update
End If
End With
Me.lblState.Visible = False
MisMsg "帐套建立成功！"
Me.MousePointer = 0
End If
Unload Me
Exit_cmdNewAccount_Click:
Exit Sub
Err_CreateBD:
MisMsg "创建 " & Trim(Me.txtDBName.Text) & "帐套出错，请重新创建！"
Me.MousePointer = 0
End Sub
Public Function DBCN(cnString As String) As Integer
On Error GoTo Err_CnString
If cn.State = 1 Then
cn.Close
End If
cn.ConnectionString = cnString
'cn.ConnectionTimeout = 300
cn.CursorLocation = adUseServer
cn.Open
DBCN = 1
Me.MousePointer = 0
Exit_dbcn:
Exit Function
Err_CnString:
MisMsg Trim(Me.txtServerName.Text) & " 连接失败！"
DBCN = 0
Me.MousePointer = 0
End Function
Private Sub cmdSelect_Click()
On Error GoTo Err_cmdSelect
Dim rstAccount As Recordset
Me.MousePointer = 11
' LocalDBCN
If Dir(App.Path & "\" & Trim(Me.txtDBName.Text) & ".Mdb") = Trim(Me.txtDBName.Text) & ".Mdb" Then
Kill App.Path & "\" & Trim(Me.txtDBName.Text) & ".Mdb"
End If
FileCopy App.Path & "\MainGalaxy.Mdb", App.Path & "\" & Trim(Me.txtDBName.Text) & ".Mdb"
If DBCN(CreateDBString) = 1 Then
Set rstAccount = New Recordset
rstAccount.Open "Select * From AccountName where AccountID='" & Me.txtAccountName.Text & "'", GetCNMain, adOpenStatic, adLockOptimistic
With rstAccount
If .EOF Then
.AddNew
![AccountID] = Me.txtDBName.Text & ""
![ServerName] = Me.txtServerName.Text & ""
![Password] = Me.txtAdminPassWord.Text & ""
![Description] = Me.txtAccountName.Text & ""
![company] = Me.txtCOName.Text & ""
![IsOA] = Me.chkOA.Value
.Update
MisMsg "联接成功！"
Else
MisMsg " 帐套： " & Me.txtAccountName.Text & " 已联接。"
End If
End With
End If
Me.MousePointer = 0
Exit Sub
Err_cmdSelect:
MisMsg "cmdSelect Error:" & Err.Description
Exit Sub
End Sub
'Public Sub LocalDBCN()
' If LocalCN.State = 1 Then LocalCN.Close
' strLink = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source= " & App.Path & "\WorkFlow.mdb;"
' LocalCN.CursorLocation = adUseClient
' If LocalCN.State = 1 Then cn.Close
' LocalCN.Open strLink
'
'End Sub
Private Sub Form_Load()
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -