📄 frm_accounttype.frm
字号:
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 195
Left = 600
TabIndex = 3
Top = 150
Width = 1095
End
End
Begin LabMangeSystem.XButton Cmd_OK
Height = 375
Left = 480
TabIndex = 37
Top = 6480
Width = 1095
_ExtentX = 1931
_ExtentY = 661
Caption = "确定"
ToolTip = "用户充值"
BackColor = 14737632
ForeColor = 8421504
MouseDownColor = -2147483644
MouseOnColor = -2147483644
StyleColor = 16777215
Style3dColor1 = 16577259
Style3dColor2 = 8421504
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
IfDraw = -1 'True
End
Begin LabMangeSystem.XButton Cmd_Close
Height = 375
Left = 1680
TabIndex = 38
Top = 6480
Width = 1095
_ExtentX = 1931
_ExtentY = 661
Caption = "关闭"
ToolTip = "刷新记录"
BackColor = 14737632
ForeColor = 8421504
MouseDownColor = -2147483644
MouseOnColor = -2147483644
StyleColor = 16777215
Style3dColor1 = 16577259
Style3dColor2 = 8421504
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
IfDraw = -1 'True
End
Begin VB.Label Lbl_Split
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "|"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00404040&
Height = 195
Left = 4530
TabIndex = 9
Top = 660
Width = 60
End
Begin VB.Label Lbl_Del
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "删除"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 4680
TabIndex = 8
Top = 660
Width = 360
End
Begin VB.Label Lbl_Add
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "添加"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 4080
TabIndex = 7
Top = 660
Width = 360
End
Begin VB.Label Lbl_AccType
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "账户类型"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00404040&
Height = 195
Left = 480
TabIndex = 6
Top = 660
Width = 720
End
Begin VB.Line Line_SplitShadow
BorderColor = &H00FFFFFF&
X1 = 255
X2 = 255
Y1 = 615
Y2 = 6855
End
Begin VB.Line Line_Split
BorderColor = &H00C0C0C0&
X1 = 240
X2 = 240
Y1 = 600
Y2 = 6840
End
End
Attribute VB_Name = "Frm_AccountType"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim AddMode As Boolean
Option Explicit
Private Sub Cmb_AccType_Click()
AddMode = False
Lbl_Add.Enabled = True
Lbl_Del.Enabled = True
Cmb_AccType.EnabledText = False
Call LoadData(Cmb_AccType.Text)
End Sub
Private Sub Cmd_Close_Click()
Call Cmd_TBarClose_Click
End Sub
Private Sub Cmd_OK_Click()
On Error GoTo ERRORZONE
Dim strSQL As String
Dim i As Integer
Dim xUserType As String
If AddMode = True Then
xUserType = Trim(Cmb_AccType.Text)
If xUserType = vbNullString Then
MsgFrm "请输入新类型的名称。", "x", "错误"
Cmb_AccType.SetFocus
Exit Sub
End If
For i = 0 To Cmb_AccType.ListCount - 1
If Cmb_AccType.List(i) = Cmb_AccType.Text Then
MsgFrm "该类型名已存在，请更换另一个新名称。", "x", "错误"
Exit Sub
End If
Next i
strSQL = "INSERT 账户类型 VALUES(" & Str2SQL(xUserType) & ","
For i = 0 To 12
strSQL = strSQL & Chk_Power(i).Value
If i < 12 Then
strSQL = strSQL & ","
Else
strSQL = strSQL & ")"
End If
Next i
cnMain.Execute strSQL
Else
xUserType = Trim(Cmb_AccType.Text)
strSQL = "UPDATE 账户类型 SET "
For i = 0 To 12
strSQL = strSQL & Lbl_Power(i) & "=" & Chk_Power(i).Value
If i < 12 Then strSQL = strSQL & ","
Next i
strSQL = strSQL & " WHERE 账户类型 = " & Str2SQL(xUserType)
cnMain.Execute strSQL
End If
Call LoadTypeList
Exit Sub
ERRORZONE:
MsgFrm Err.Description, "x", "错误"
End Sub
Private Sub Cmd_TBarClose_Click()
Unload Me
Frm_Welcome.Show
Set LastForm = Frm_Welcome
End Sub
Private Sub Form_Load()
Call HideContorl
If HavePower("修改账户权限") = False Then
Lbl_TBarText.ForeColor = RGB(255, 0, 0)
Lbl_TBarText.caption = "您没有权限完成当前操作！"
Exit Sub
End If
Lbl_TBarText.caption = Me.caption
Call ShowContorl
Call LoadTypeList
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Lbl_Add.FontUnderline = False
Lbl_Del.FontUnderline = False
Lbl_Add.ForeColor = RGB(0, 0, 255)
Lbl_Del.ForeColor = RGB(0, 0, 255)
End Sub
Private Sub Form_Resize()
On Error Resume Next
Frame_AccPower.Width = Me.Width - Frame_AccPower.Left - 240 - 45
Lbl_Tip.Width = Frame_AccPower.Width - Lbl_Tip.Left - 240 - 45
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call ShowTip
End Sub
Private Sub Lbl_Add_Click()
On Error Resume Next
AddMode = True
Lbl_Add.Enabled = False
Lbl_Del.Enabled = False
Cmb_AccType.EnabledText = True
Cmb_AccType.SetFocus
End Sub
Private Sub Lbl_Add_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Lbl_Add.FontUnderline = True
Lbl_Add.ForeColor = &HFFC0C0
End Sub
Private Sub Lbl_Del_Click()
Dim i As Integer
Dim xUserType As String
xUserType = Trim(Cmb_AccType.Text)
If FindUser(xUserType) = True Then
MsgFrm "检测到有账户为 [ " & xUserType & " ] ，无法删除。", "x", "错误"
Exit Sub
End If
If MsgFrm("确实要删除 [ " & xUserType & " ] 类型吗？" & vbCrLf & _
"提示：该操作不撤销！", "?", "删除账户类型") = 2 Then Exit Sub
cnMain.Execute "DELETE FROM 账户类型 WHERE 账户类型 = " & Str2SQL(xUserType)
For i = 0 To Cmb_AccType.ListCount - 1
If Cmb_AccType.List(i) = xUserType Then
Cmb_AccType.RemoveItem i
End If
Next i
Call LoadTypeList
End Sub
Private Sub Lbl_Del_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Lbl_Del.FontUnderline = True
Lbl_Del.ForeColor = &HFFC0C0
End Sub
Private Sub Lbl_Power_Click(Index As Integer)
Chk_Power(Index).Value = Chk_Power(Index).Value Xor 1
End Sub
Private Sub Pic_TitleBar_Resize()
On Error Resume Next
Cmd_TBarClose.Left = Pic_TitleBar.Width - 24 * 15
End Sub
'隐藏所有控件
Private Sub HideContorl()
Lbl_AccType.Visible = False
Cmb_AccType.Visible = False
Lbl_Add.Visible = False
Lbl_Split.Visible = False
Lbl_Del.Visible = False
Frame_AccPower.Visible = False
Cmd_OK.Visible = False
Cmd_Close.Visible = False
End Sub
'显示所有控件
Private Sub ShowContorl()
Lbl_AccType.Visible = True
Cmb_AccType.Visible = True
Lbl_Add.Visible = True
Lbl_Split.Visible = True
Lbl_Del.Visible = True
Frame_AccPower.Visible = True
Cmd_OK.Visible = True
Cmd_Close.Visible = True
End Sub
'加载账户类型列表
Private Sub LoadTypeList()
On Error GoTo ERRORZONE
Dim i As Integer
Dim strSQL As String
Dim rs As New ADODB.Recordset
strSQL = "SELECT * FROM 账户类型"
rs.Open strSQL, cnMain, 1, 1
Cmb_AccType.Clear
For i = 0 To rs.RecordCount - 1
Cmb_AccType.AddItem rs("账户类型")
rs.MoveNext
Next i
With Lbl_Power
For i = 1 To rs.Fields.Count - 1
Lbl_Power(i - 1).caption = rs(i).Name
Chk_Power(i - 1).Value = 0
Next i
End With
Set rs = New ADODB.Recordset
strSQL = "SELECT COUNT(修改账户权限) AS 数量 FROM 账户类型 WHERE 修改账户权限 = 1 GROUP BY 修改账户权限"
rs.Open strSQL, cnMain, 1, 1
Lbl_Tip.caption = "当前有 " & rs("数量") & " 个类型拥有账户修改权限"
If rs("数量") <= 1 Then Lbl_Tip.caption = Lbl_Tip.caption & vbNewLine & "注意：请至少保留一个类型拥有账户修改权限，否则需要联系系统数据库管理员进行修改。"
Exit Sub
ERRORZONE:
MsgFrm Err.Description, "x", "错误"
End Sub
'加载账户权限数据
Private Sub LoadData(strTypeName As String)
On Error GoTo ERRORZONE
Dim i As Integer
Dim strSQL As String
Dim rs As New ADODB.Recordset
strSQL = "SELECT * FROM 账户类型 WHERE 账户类型 = " & Str2SQL(strTypeName)
rs.Open strSQL, cnMain, 1, 1
For i = 1 To rs.Fields.Count - 1
Chk_Power(i - 1).Value = IIf(rs(i).Value = True, 1, 0)
Next i
Exit Sub
ERRORZONE:
MsgFrm Err.Description, "x", "错误"
End Sub
'(在删除之前)查找是否存在该类型用户
Private Function FindUser(strUserName As String) As Boolean
Dim rs As New ADODB.Recordset
Dim strSQL As String
strSQL = "SELECT * FROM 账户 WHERE 账户类型 = " & Str2SQL(strUserName)
rs.Open strSQL, cnMain, 1, 1
FindUser = IIf(rs.EOF, False, True)
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -