📄 classplusmanager.ctl
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.UserControl GuestManager
ClientHeight = 2790
ClientLeft = 0
ClientTop = 0
ClientWidth = 6225
LockControls = -1 'True
PropertyPages = "ClassPlusManager.ctx":0000
ScaleHeight = 2790
ScaleWidth = 6225
ToolboxBitmap = "ClassPlusManager.ctx":000F
Begin VB.PictureBox Picture2
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 2520
Left = 180
ScaleHeight = 2520
ScaleWidth = 4275
TabIndex = 8
Top = 75
Visible = 0 'False
Width = 4275
Begin VB.TextBox txtPrice
Height = 300
Left = 570
TabIndex = 1
Top = 1440
Width = 2760
End
Begin VB.CommandButton Command1
Caption = "取消(&C)"
Height = 405
Index = 1
Left = 2205
TabIndex = 3
Top = 1935
Width = 1155
End
Begin VB.CommandButton Command1
Caption = "保存(&S)"
Enabled = 0 'False
Height = 405
Index = 0
Left = 975
TabIndex = 2
Top = 1935
Width = 1155
End
Begin VB.TextBox StoreName
Height = 300
Left = 570
TabIndex = 0
Top = 720
Width = 2760
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Pop3服务器："
ForeColor = &H00800000&
Height = 180
Index = 1
Left = 570
TabIndex = 11
Top = 1170
Width = 1080
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Smtp服务器："
ForeColor = &H000000C0&
Height = 180
Index = 0
Left = 555
TabIndex = 9
Top = 435
Width = 1080
End
End
Begin VB.PictureBox Picture1
BackColor = &H00808080&
BorderStyle = 0 'None
Height = 2640
Left = 4470
ScaleHeight = 2640
ScaleWidth = 1680
TabIndex = 7
Top = 90
Width = 1680
Begin VB.CommandButton ExitButton
Caption = "关闭退出"
Height = 870
Left = 0
Picture = "ClassPlusManager.ctx":0321
Style = 1 'Graphical
TabIndex = 6
Top = 1740
Width = 1650
End
Begin VB.CommandButton StoreDelete
Caption = "删除 Smtp"
Height = 870
Left = 0
Picture = "ClassPlusManager.ctx":062B
Style = 1 'Graphical
TabIndex = 5
Top = 870
Width = 1650
End
Begin VB.CommandButton AddStore
Caption = "添加 Smtp"
Height = 870
Left = 0
Picture = "ClassPlusManager.ctx":0935
Style = 1 'Graphical
TabIndex = 4
Top = 0
Width = 1650
End
End
Begin MSFlexGridLib.MSFlexGrid Grid1
Height = 2715
Left = 45
TabIndex = 10
Top = 75
Width = 4425
_ExtentX = 7805
_ExtentY = 4789
_Version = 393216
Rows = 10
Cols = 4
BackColor = 16777215
BackColorSel = 8421376
BackColorBkg = 12632256
AllowBigSelection= 0 'False
FocusRect = 0
ScrollBars = 2
SelectionMode = 1
BorderStyle = 0
End
End
Attribute VB_Name = "GuestManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
'缺省属性值:
Const m_def_IsGuest = 0
Const m_def_sDatabaseFile = ""
Const m_def_sTableName = ""
Const m_def_sDatabasePassword = ""
'属性变量:
Dim m_sDatabaseFile As String
Dim m_sTableName As String
Dim m_sDatabasePassword As String
Private Sub AddStore_Click()
Grid1.Visible = False
AddStore.Enabled = False
StoreDelete.Enabled = False
ExitButton.Enabled = False
Picture2.Visible = True
StoreName.Text = ""
txtPrice.Text = ""
StoreName.SetFocus
End Sub
Private Sub Command1_Click(Index As Integer)
On Error Resume Next
If Index = 1 Then
AddStore.Enabled = True
StoreDelete.Enabled = True
ExitButton.Enabled = True
Picture2.Visible = False
Grid1.Visible = True
StoreName.Text = ""
Exit Sub
End If
'保存记录
Dim DB As Database, EF As Recordset, RecStr As String
Set DB = OpenDatabase(m_sDatabaseFile, 0, 0, m_sDatabasePassword)
Set EF = DB.OpenRecordset(m_sTableName, dbOpenDynaset)
RecStr = "Class='" & Trim(StoreName.Text) & "'"
EF.FindFirst RecStr
If EF.NoMatch Then
EF.AddNew
EF.Fields("Class") = Trim(StoreName.Text)
EF.Fields("Price") = Trim(txtPrice.Text)
EF.Update
EF.Close
DB.Close
StoreName.Text = ""
Else
EF.Close
DB.Close
MsgBox "您添加的 Smtp Server 已经存在! " & vbCrLf & vbCrLf & " 请修改后继续 ...... ", vbOKOnly + 64, "重复的 Smtp Server 名称"
StoreName.Text = ""
StoreName.SetFocus
Exit Sub
End If
'配置网格
On Error GoTo Add_Err
Grid1.Visible = False
Grid1.Clear
Grid1.Cols = 3
Grid1.FormatString = "^ 序号 |^ Smtp Server |^ Pop3 Server "
Grid1.ColWidth(0) = 530
Grid1.ColWidth(1) = 1900
Grid1.ColWidth(2) = 1900
Dim HH As Integer
Set DB = OpenDatabase(m_sDatabaseFile, 0, 0, m_sDatabasePassword)
Set EF = DB.OpenRecordset(m_sTableName, dbOpenTable)
Grid1.Rows = EF.RecordCount + 4
Set EF = DB.OpenRecordset("Select * From " & m_sTableName, dbOpenDynaset)
HH = 1
Do While Not EF.EOF()
Grid1.Row = HH
Grid1.Col = 1
Grid1.CellAlignment = 1
If Not IsNull(EF.Fields("Class").Value) Then
Grid1.Text = EF.Fields("Class").Value
End If
Grid1.Col = 2
Grid1.CellAlignment = 1
If Not IsNull(EF.Fields("Price").Value) Then
Grid1.Text = EF.Fields("Price").Value
End If
EF.MoveNext
HH = HH + 1
Loop
DB.Close
Grid1.Col = 1
Grid1.Row = 1
Grid1.ColSel = 2
Grid1.Visible = True
AddStore.Enabled = True
StoreDelete.Enabled = True
ExitButton.Enabled = True
Picture2.Visible = False
Exit Sub
Add_Err:
MsgBox "对不起，显示网格！ ", vbInformation
End Sub
Private Sub ExitButton_Click()
Unload UserControl.Parent
End Sub
Private Sub StoreDelete_Click()
If Grid1.Text = "" Or Grid1.MouseCol = 0 Or Grid1.MouseRow = 0 Then Exit Sub
Dim QR As Integer
QR = MsgBox("真的要删除 Smtp Server [" & Grid1.Text & "]吗？(Y/N)", vbYesNo + 16, "删除确认")
If QR = 7 Then
Exit Sub
End If
'删除记录
Dim DB As Database, RecStr As String
Set DB = OpenDatabase(m_sDatabaseFile, 0, 0, m_sDatabasePassword)
RecStr = "Class='" & Grid1.Text & "'"
RecStr = "Delete * From " & m_sTableName & " Where " & RecStr
DB.Execute RecStr
DB.Close
'移去删除的行
Grid1.RemoveItem Grid1.Row
End Sub
Private Sub StoreName_Change()
If Trim(StoreName) <> "" Then
Command1(0).Enabled = True
Else
Command1(0).Enabled = False
End If
End Sub
Private Sub StoreName_GotFocus()
StoreName.SelStart = 0
StoreName.SelLength = Len(StoreName)
End Sub
Private Sub StoreName_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
End If
End Sub
Private Sub StoreName_LostFocus()
On Error Resume Next
txtPrice.Text = "Pop" & Mid(StoreName.Text, InStr(1, StoreName, ".", vbTextCompare))
End Sub
Private Sub txtPrice_GotFocus()
txtPrice.SelStart = 0
txtPrice.SelLength = Len(txtPrice)
End Sub
Private Sub txtPrice_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Command1(0).SetFocus
End If
End Sub
Private Sub UserControl_Resize()
If UserControl.Width < 6225 Then
UserControl.Width = 6225
End If
If UserControl.Height < 2797 Then
UserControl.Height = 2797
End If
End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,0
Public Property Get sDatabaseFile() As String
Attribute sDatabaseFile.VB_ProcData.VB_Invoke_Property = "数据配置"
sDatabaseFile = m_sDatabaseFile
End Property
Public Property Let sDatabaseFile(ByVal New_sDatabaseFile As String)
m_sDatabaseFile = New_sDatabaseFile
PropertyChanged "sDatabaseFile"
End Property
'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,0
Public Property Get sTableName() As String
Attribute sTableName.VB_ProcData.VB_Invoke_Property = "数据配置"
sTableName = m_sTableName
End Property
Public Property Let sTableName(ByVal New_sTableName As String)
m_sTableName = New_sTableName
PropertyChanged "sTableName"
End Property
'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,0
Public Property Get sDatabasePassword() As String
Attribute sDatabasePassword.VB_ProcData.VB_Invoke_Property = "数据配置"
sDatabasePassword = m_sDatabasePassword
End Property
Public Property Let sDatabasePassword(ByVal New_sDatabasePassword As String)
m_sDatabasePassword = New_sDatabasePassword
PropertyChanged "sDatabasePassword"
End Property
'为用户控件初始化属性
Private Sub UserControl_InitProperties()
m_sDatabaseFile = m_def_sDatabaseFile
m_sTableName = m_def_sTableName
m_sDatabasePassword = m_def_sDatabasePassword
m_IsGuest = m_def_IsGuest
End Sub
'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_sDatabaseFile = PropBag.ReadProperty("sDatabaseFile", m_def_sDatabaseFile)
m_sTableName = PropBag.ReadProperty("sTableName", m_def_sTableName)
m_sDatabasePassword = PropBag.ReadProperty("sDatabasePassword", m_def_sDatabasePassword)
m_IsGuest = PropBag.ReadProperty("IsGuest", m_def_IsGuest)
End Sub
Private Sub UserControl_Show()
WriteGrid
End Sub
'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("sDatabaseFile", m_sDatabaseFile, m_def_sDatabaseFile)
Call PropBag.WriteProperty("sTableName", m_sTableName, m_def_sTableName)
Call PropBag.WriteProperty("sDatabasePassword", m_sDatabasePassword, m_def_sDatabasePassword)
Call PropBag.WriteProperty("IsGuest", m_IsGuest, m_def_IsGuest)
End Sub
Private Sub WriteGrid()
Picture2.Visible = False
'配置网格
Grid1.Visible = False
Grid1.Cols = 3
Grid1.FormatString = "^ 序号 |^ Smtp Server |^ Pop3 Server "
Grid1.ColWidth(0) = 530
Grid1.ColWidth(1) = 1900
Grid1.ColWidth(2) = 1900
If m_sDatabaseFile <> "" Then
Dim DB As Database, EF As Recordset, HH As Integer
Set DB = OpenDatabase(m_sDatabaseFile, 0, 0, m_sDatabasePassword)
Set EF = DB.OpenRecordset(m_sTableName, dbOpenTable)
Grid1.Rows = EF.RecordCount + 4
Set EF = DB.OpenRecordset("Select * From " & m_sTableName, dbOpenDynaset)
HH = 1
Do While Not EF.EOF()
Grid1.Row = HH
Grid1.Col = 1
Grid1.CellAlignment = 1
If Not IsNull(EF.Fields("Class").Value) Then
Grid1.Text = EF.Fields("Class").Value
End If
Grid1.Col = 2
Grid1.CellAlignment = 1
If Not IsNull(EF.Fields("Price").Value) Then
Grid1.Text = EF.Fields("Price").Value
End If
EF.MoveNext
HH = HH + 1
Loop
DB.Close
Else '数据库文件为空时
Grid1.Rows = 10
Grid1.Col = 1
Grid1.ColSel = 2
Grid1.Visible = True
Exit Sub
End If
Grid1.Col = 1
Grid1.Row = 1
Grid1.ColSel = 2
Grid1.Visible = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -