📄 frmrea.frm
字号:
VERSION 5.00
Object = "{B02F3647-766B-11CE-AF28-C3A2FBE76A13}#2.5#0"; "SS32X25.OCX"
Begin VB.Form frmRea
Caption = "Driver Status Info Maintenance"
ClientHeight = 6840
ClientLeft = 60
ClientTop = 345
ClientWidth = 9645
LinkTopic = "Form1"
MDIChild = -1 'True
ScaleHeight = 6840
ScaleWidth = 9645
WindowState = 2 'Maximized
Begin FPSpread.vaSpread vasrea
Height = 3075
Left = 120
TabIndex = 7
Top = 720
Width = 9000
_Version = 131077
_ExtentX = 15875
_ExtentY = 5424
_StockProps = 64
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
MaxCols = 1
MaxRows = 1
SpreadDesigner = "frmRea.frx":0000
End
Begin VB.Frame frminput
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2655
Left = 120
TabIndex = 1
Top = 3960
Width = 9015
Begin VB.TextBox txtdesc
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 270
Left = 1440
MaxLength = 15
TabIndex = 3
Top = 1560
Width = 2055
End
Begin VB.TextBox txtcode
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 270
Left = 1440
MaxLength = 3
TabIndex = 2
Top = 480
Width = 495
End
Begin VB.Label Label2
Caption = "Description:"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 240
TabIndex = 5
Top = 1560
Width = 1215
End
Begin VB.Label Label1
Caption = "Reason Code:"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 240
TabIndex = 4
Top = 480
Width = 1215
End
End
Begin PrjLDS.UserControl1 UserControl1
Height = 615
Left = 0
TabIndex = 0
Top = 0
Width = 9615
_ExtentX = 17224
_ExtentY = 1085
End
Begin VB.Label lblstatus
Height = 255
Left = 8040
TabIndex = 6
Top = 2880
Width = 735
End
End
Attribute VB_Name = "frmRea"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mkey As String
Dim lCurRow As Integer
Dim lCurCol As Integer
Private Sub Form_Load()
lCurRow = 1
lCurCol = 1
Call initspread
Call vasshow
Call InitToolBar
frminput.Enabled = False
End Sub
Private Sub initspread()
With vasrea
.MaxRows = 0
.MaxCols = 2 'enuDetailCols.MaxCols
.ShadowColor = genuBACKCOLOR.CST_Grid_LostFocus
.Row = -1: .Col = -1
.BackColor = genuBACKCOLOR.CST_Grid_LostFocus
.GridColor = vbBlack
End With
Call SetSpreadHead
lockspread vasrea, True
End Sub
Private Sub SetSpreadHead()
SetColHead vasrea, 1, "Reason Code", 16
SetColHead vasrea, 2, "Description", 26
End Sub
Private Sub vasshow()
Dim sSQL As String
Dim rstrea As Recordset
Dim lrow As Integer
sSQL = "select * from sysrea"
Set rstrea = Acs_cnt.Execute(sSQL)
vasrea.MaxRows = 0
lrow = 0
Do While Not rstrea.EOF
vasrea.MaxRows = vasrea.MaxRows + 1
lrow = lrow + 1
SetValue vasrea, lrow, 1, rstrea!reacode
SetValue vasrea, lrow, 2, rstrea!readesc
rstrea.MoveNext
Loop
rstrea.Close
Set rstrea = Nothing
Call vasrea_Click(lCurCol, lCurRow)
End Sub
Private Sub InitToolBar()
With UserControl1
.DisplayButton "New", "New", True, , "New"
.DisplayButton "Save", "Save", False, , "Save"
.DisplayButton "Cancel", "Cancel", False, , "Cancel"
'.DisplayButton "Redo", "Redo", False, , "Redo"
.DisplayButton "Modify", "Modify", True, , "Modify"
.DisplayButton "Find", "Find", True, , "Find"
.DisplayButton "Delete", "Delete", True, , "Delete"
.DisplayButton "Close", "Close", True, , "Close"
End With
Call EnableDelete(gsRoleCode, UserControl1)
End Sub
Private Sub SetToolBar(ByVal mkey As String)
Select Case mkey
Case "new"
With UserControl1
.DisplayButton "New", "New", False, , "New"
.DisplayButton "Find", "Find", False, , "Find"
'.DisplayButton "Print", "Print", True, , "Print"
.DisplayButton "Modify", "Modify", False, , "Modify"
.DisplayButton "Save", "Save", True, , "Save"
.DisplayButton "Cancel", "Cancel", True, , "Cancel"
.DisplayButton "Delete", "Delete", False, , "Delete"
.DisplayButton "Close", "Close", False, , "Close"
End With
vasrea.Enabled = False
frminput.Enabled = True
txtcode.Enabled = True
txtdesc.Enabled = True
txtcode.SetFocus
Case "modify"
With UserControl1
.DisplayButton "New", "New", False, , "New"
.DisplayButton "Find", "Find", False, , "Find"
.DisplayButton "Delete", "Delete", False, , "Delete"
.DisplayButton "Modify", "Modify", False, , "Modify"
.DisplayButton "Save", "Save", True, , "Save"
.DisplayButton "Cancel", "Cancel", True, , "Cancel"
'.DisplayButton "Redo", "Redo", True, , "Redo"
.DisplayButton "Close", "Close", False, , "Close"
End With
vasrea.Enabled = False
frminput.Enabled = True
txtcode.Enabled = False
txtdesc.Enabled = True
txtdesc.SetFocus
Case "cancel"
With UserControl1
.DisplayButton "New", "New", True, , "New"
.DisplayButton "Find", "Find", True, , "Find"
.DisplayButton "Delete", "Delete", True, , "Delete"
.DisplayButton "Modify", "Modify", True, , "Modify"
.DisplayButton "Save", "Save", False, , "Save"
.DisplayButton "Cancel", "Cancel", False, , "Cancel"
'.DisplayButton "Redo", "Redo", False, , "Redo"
.DisplayButton "Close", "Close", True, , "Close"
End With
vasrea.Enabled = True
frminput.Enabled = False
lblstatus.Caption = ""
Call vasshow
Case "find"
With UserControl1
.DisplayButton "New", "New", False, , "New"
.DisplayButton "Find", "Find", False, , "Find"
.DisplayButton "Delete", "Delete", True, , "Delete"
.DisplayButton "Save", "Save", False, , "Save"
.DisplayButton "Modify", "Modify", True, , "Modify"
.DisplayButton "Cancel", "Cancel", True, , "Cancel"
'.DisplayButton "Redo", "Redo", True, , "Redo"
.DisplayButton "Close", "Close", False, , "Close"
End With
vasrea.Enabled = False
frminput.Enabled = True
txtcode.Enabled = True
txtdesc.Enabled = False
txtcode.SetFocus
Case "delete"
With UserControl1
.DisplayButton "New", "New", True, , "New"
.DisplayButton "Find", "Find", True, , "Find"
.DisplayButton "Delete", "Delete", True, , "Delete"
.DisplayButton "Save", "Save", False, , "Save"
.DisplayButton "Modify", "Modify", True, , "Modify"
.DisplayButton "Cancel", "Cancel", False, , "Cancel"
'.DisplayButton "Redo", "Redo", False, , "Redo"
.DisplayButton "Close", "Close", True, , "Close"
End With
vasrea.Enabled = False
frminput.Enabled = True
Call vasshow
Case "save"
With UserControl1
.DisplayButton "New", "New", True, , "New"
.DisplayButton "Find", "Find", True, , "Find"
.DisplayButton "Delete", "Delete", True, , "Delete"
.DisplayButton "Save", "Save", False, , "Save"
.DisplayButton "Modify", "Modify", True, , "Modify"
.DisplayButton "Cancel", "Cancel", False, , "Cancel"
'.DisplayButton "Redo", "Redo", False, , "Redo"
.DisplayButton "Close", "Close", True, , "Close"
End With
vasrea.Enabled = True
frminput.Enabled = False
Call vasshow
End Select
Call EnableDelete(gsRoleCode, UserControl1)
End Sub
Private Sub txtcode_KeyUp(KeyCode As Integer, Shift As Integer)
Dim rststa As Recordset
Dim sSQL As String
Dim sCode As String
If KeyCode = vbKeyReturn Then
If txtcode.Text = "" Then
ElseIf lblstatus.Caption = "search" Then
sCode = txtcode.Text
sSQL = "select * from sysrea where reacode = '" & sCode & "'"
Set rststa = Acs_cnt.Execute(sSQL)
If Not rststa.EOF Then
txtdesc.Text = rststa!readesc
Else
txtdesc.Text = ""
End If
rststa.Close
Set rststa = Nothing
Else
SendKeys "{tab}"
End If
End If
End Sub
Private Sub UserControl1_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error Resume Next
mkey = LCase(Button.Key)
Select Case LCase(Button.Key)
Case "new"
lblstatus.Caption = mkey
Call IniReaDetail
Case "save"
If lblstatus.Caption = "new" Then
If SaveReaInfo = False Then
Exit Sub
End If
ElseIf lblstatus.Caption = "modify" Then
Call ModifyReaInfo
End If
Case "delete"
If MsgBox("Are sure to delete this record!", vbYesNo, "Message") = vbYes Then
Call DeleteReaInfo
Call vasshow
Else
Exit Sub
End If
Case "find"
lblstatus.Caption = "search"
Call IniReaDetail
Case "modify"
lblstatus.Caption = mkey
Case "close"
Unload Me
Exit Sub
Case Else
End Select
Call SetToolBar(mkey)
End Sub
Private Sub IniReaDetail()
txtcode.Text = ""
txtdesc.Text = ""
End Sub
Private Sub DeleteReaInfo()
Dim sSQL As String
Dim sCode As String
sCode = txtcode.Text
sSQL = "delete from sysRea where Reacode='" & sCode & "'"
Acs_cnt.BeginTrans
Acs_cnt.Execute (sSQL)
Acs_cnt.CommitTrans
End Sub
Private Sub ModifyReaInfo()
Dim sSQL As String
Dim sCode As String
Dim sdesc As String
sCode = txtcode.Text
sdesc = txtdesc.Text
sSQL = "update sysRea set Readesc='" & sdesc & "' where Reacode='" & sCode & "'"
Acs_cnt.BeginTrans
Acs_cnt.Execute (sSQL)
Acs_cnt.CommitTrans
End Sub
Private Function SaveReaInfo() As Boolean
Dim sCode As String, sdesc As String
Dim rstrea As Recordset
Dim sSQL As String, sRole As String
SaveReaInfo = False
sCode = Trim(txtcode.Text)
sdesc = Trim(txtdesc.Text)
sSQL = "select * from sysRea where Reacode='" & sCode & "'"
Set rstrea = Acs_cnt.Execute(sSQL)
With rstrea
If Not .EOF Then
MsgBox "This ReaCode is exist,please change the Reacode!", vbInformation, "Error"
Exit Function
End If
End With
sSQL = "insert into sysRea(Reacode,Readesc)" & " values('" & sCode & "','" & sdesc & "')"
Acs_cnt.BeginTrans
Acs_cnt.Execute (sSQL)
Acs_cnt.CommitTrans
rstrea.Close
Set rstrea = Nothing
SaveReaInfo = True
End Function
Private Sub vasrea_Click(ByVal Col As Long, ByVal Row As Long)
Dim lrow As Integer
lrow = Row
If Row > 0 Then
txtcode.Text = GetValue(vasrea, lrow, 1)
txtdesc.Text = GetValue(vasrea, lrow, 2)
Else
End If
End Sub
Private Sub vasrea_KeyUp(KeyCode As Integer, Shift As Integer)
Dim lrow, lcol As Long
lrow = vasrea.ActiveRow
lcol = vasrea.ActiveCol
If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then
Call vasrea_Click(lcol, lrow)
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -