📄 register.frm
字号:
VERSION 5.00
Begin VB.Form Register
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
Caption = "欢迎使用Web管理控制台"
ClientHeight = 2940
ClientLeft = 45
ClientTop = 330
ClientWidth = 6900
Icon = "Register.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2940
ScaleWidth = 6900
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton CmdCommand
BackColor = &H00E0E0E0&
Caption = "新建"
Height = 375
Index = 0
Left = 2070
Style = 1 'Graphical
TabIndex = 5
Top = 2430
Width = 975
End
Begin VB.Frame FraLogon
BackColor = &H00FFFFFF&
Caption = "登录"
BeginProperty Font
Name = "System"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 2295
Left = 2100
TabIndex = 6
Top = 0
Width = 4740
Begin VB.ComboBox cmbWebName
Height = 315
Left = 1905
Style = 2 'Dropdown List
TabIndex = 2
Top = 1680
Width = 2610
End
Begin VB.TextBox TxtName
BeginProperty Font
Name = "System"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 1260
TabIndex = 0
Text = "SYSTEM"
Top = 420
Width = 3255
End
Begin VB.TextBox TxtPassword
BeginProperty Font
Name = "System"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
IMEMode = 3 'DISABLE
Left = 1260
PasswordChar = "*"
TabIndex = 1
Top = 1005
Width = 3255
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "WEB站点名称："
BeginProperty Font
Name = "System"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 240
Left = 300
TabIndex = 9
Top = 1695
Width = 1545
End
Begin VB.Label LabName
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "姓名："
BeginProperty Font
Name = "System"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 240
Left = 300
TabIndex = 8
Top = 480
Width = 630
End
Begin VB.Label LabPassword
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "密码："
BeginProperty Font
Name = "System"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 240
Left = 300
TabIndex = 7
Top = 1080
Width = 630
End
End
Begin VB.CommandButton CmdCommand
BackColor = &H00E0E0E0&
Caption = "关闭"
Height = 375
Index = 2
Left = 5625
Style = 1 'Graphical
TabIndex = 4
Top = 2415
Width = 975
End
Begin VB.CommandButton CmdCommand
BackColor = &H00E0E0E0&
Cancel = -1 'True
Caption = "确认"
Default = -1 'True
Height = 375
Index = 1
Left = 4440
Style = 1 'Graphical
TabIndex = 3
Top = 2430
Width = 975
End
Begin VB.Image Image1
Height = 2535
Left = -15
Picture = "Register.frx":0CCA
Stretch = -1 'True
Top = 135
Width = 1980
End
End
Attribute VB_Name = "Register"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmbWebName_Click()
Curwebinfo(0, 0) = WebInfo(cmbWebName.ListIndex, 0)
Curwebinfo(0, 1) = WebInfo(cmbWebName.ListIndex, 1)
Curwebinfo(0, 2) = WebInfo(cmbWebName.ListIndex, 2)
Curwebinfo(0, 3) = WebInfo(cmbWebName.ListIndex, 3)
End Sub
Private Sub cmbWebName_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
SendKeys "{tab}"
End If
End Sub
Private Sub CmdCommand_Click(Index As Integer)
Dim Username, pws As String
On Error GoTo DatabaseError
Select Case Index
Case 0
'新建
Unload Me
FrmConfigMain.Show
Case 1
'确定
If cmbWebName.ListIndex < 0 Then
MsgBox "请选择一个需要管理的站点名称！", 48, "系统提示"
cmbWebName.SetFocus
Exit Sub
End If
rdoEngine.rdoRegisterDataSource "bkbtinfo", _
"Microsoft Access Driver (*.mdb)", True, _
"DBQ=" & Trim(App.Path) & "\DATABASE\bkbtinfo.mdb"
Set gclsDatabase = New DataAccess
Call gclsDatabase.CreateRDODatabaseConnection
'判断
Sevname = Curwebinfo(0, 2)
dbName = Curwebinfo(0, 3)
If Len(Trim(TxtName.Text)) = 0 Then
MsgBox "姓名不能为空！", vbExclamation, "系统信息"
TxtName.SetFocus
Exit Sub
Else
sql = "SELECT * FROM admin"
Set rst = gclsDatabase.RDOSelect(sql)
KKK = rst.RowCount
If KKK > 0 Then
Username = rst!Admin
pws = rst!adminpwd
End If
rst.Close
If KKK > 0 Then
If Trim(Username) = Trim(TxtName.Text) And Trim(pws) = Trim(TxtPassword.Text) Then
Else
MsgBox "姓名或密码不正确！", vbExclamation, "系统信息"
TxtName.SetFocus
Exit Sub
End If
End If
End If
rdoEngine.rdoRegisterDataSource "BKBTINFO", _
"SQL Server", True, _
"SERVER=" & Sevname & Chr(13) & "DATABASE=" & dbName & Chr(13)
Set gclsDatabase = New DataAccess
Call gclsDatabase.CreateRDODatabaseConnection
sql = "SELECT * FROM treedefault"
Set rst = gclsDatabase.RDOSelect(sql)
If rst.RowCount > 0 Then
DefFont = Trim(rst!Font)
DefFontSize = rst!FontSize
DefStaticColor = Trim(rst!staticcolor)
DefDynamicColor = Trim(rst!dynamiccolor)
Else
sql = "INSERT INTO treedefault VALUES("
sql = sql & "'宋体',20,'&H00FFFFFF&','&H000000FF&')"
Return_Var = gclsDatabase.RDOInsert(sql)
If Return_Var = 0 Then GoTo DatabaseError
DefFont = "宋体"
DefFontSize = 20
DefStaticColor = "&H00FFFFFF&"
DefDynamicColor = "&H000000FF&"
End If
rst.Close
sql = "SELECT * FROM mainpagepath"
Set rst = gclsDatabase.RDOSelect(sql)
SysPath = rst(0)
rst.Close
Unload Me
MDIManage.Show
'End If
Case 2
'关闭
End
End Select
Exit Sub
DatabaseError:
Call ManageQuit
End Sub
Private Sub CmdDataInit_Click()
Dim MyConn As New ADODB.Connection
'Dim Rs As New ADODB.Recordset
Dim connstr As String
Dim CreateDeviceStr As String
Dim CreateDataStr As String
Dim CreateTableStr As String
Dim tempPath As String
Dim MySql As String
On Error GoTo DatabaseError
If Trim(txtDomain.Text) = "" Then
MsgBox "必须输入系统的域名！", 48, "系统提示"
txtDomain.SetFocus
Exit Sub
End If
If Trim(txtUID.Text) = "" Then
MsgBox "必须输入数据库管理员的用户名和口令！", 48, "系统提示"
txtUID.SetFocus
Exit Sub
End If
If WebExist("bk2000") = 1 Then
Exit Sub
End If
rdoEngine.rdoRegisterDataSource "bkbtinfo", _
"Microsoft Access Driver (*.mdb)", True, _
"DBQ=" & Trim(PathName) & "\bkbtinfo.mdb"
Set gclsDatabase = New DataAccess
Call gclsDatabase.CreateRDODatabaseConnection
sql = "SELECT * FROM 数据库操作"
Set rst = gclsDatabase.RDOSelect(sql)
If rst.RowCount > 0 Then
CreateDeviceStr = Replace(Trim(rst!创建设备), "^", "'")
tempPath = Mid(App.Path, 1, 1) & ":\webmanager"
aaa = Dir(tempPath, vbDirectory)
If aaa <> "" Then
aaa = ""
aaa = Dir(tempPath & "\bkbtinfo.dat")
If aaa <> "" Then
MsgBox "系统中已存在指定的数据库文件，请与开发商联系！", 48, "系统提示"
Exit Sub
End If
Else
MkDir tempPath
End If
tempPath = tempPath & "\bkbtinfo.dat"
CreateDeviceStr = Replace(CreateDeviceStr, "c:\mssql\data\bkbtinfo.dat", tempPath)
CreateDataStr = Replace(Trim(rst!创建数据库), "^", "'")
Else
rst.Close
gclsDatabase.CloseRDODatabaseConnection
Set gclsDatabase = Nothing
If Len(Trim(PathName)) <> 0 Then
Return_Var = SetCurrentDirectory(PathName)
End If
End
End If
rst.Close
LabSysInfo.Visible = True
LabSysInfo.Refresh
Screen.MousePointer = 11
connstr = "Driver={SQL SERVER};SERVER=(local);UID=" & Trim(txtUID) & ";PWD=" & Trim(Txtpwd) & ";DATABASE=master"
MyConn.Open connstr
LabSysInfo = "正在建立新的数据库设备"
LabSysInfo.Refresh
MyConn.Execute CreateDeviceStr, 64
LabSysInfo = "正在建立新的数据库"
LabSysInfo.Refresh
MyConn.Execute CreateDataStr, 64
MyConn.Close
sql = "SELECT * FROM 数据表创建 ORDER BY 序号"
Set rst = gclsDatabase.RDOSelect(sql)
If rst.RowCount > 0 Then
connstr = "Driver={SQL SERVER};SERVER=(LOCAL);UID=" & Trim(txtUID) & ";PWD=" & Trim(Txtpwd) & ";DATABASE=bkbtinfo"
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -