📄 frmsta.frm
字号:
VERSION 5.00
Object = "{B02F3647-766B-11CE-AF28-C3A2FBE76A13}#2.5#0"; "SS32X25.OCX"
Begin VB.Form frmSta
Caption = "Truck Status Info Maintenance"
ClientHeight = 6840
ClientLeft = 60
ClientTop = 345
ClientWidth = 9450
LinkTopic = "Form1"
MDIChild = -1 'True
ScaleHeight = 6840
ScaleWidth = 9450
WindowState = 2 'Maximized
Begin PrjLDS.UserControl1 UserControl1
Height = 615
Left = 0
TabIndex = 7
Top = 0
Width = 9570
_ExtentX = 16880
_ExtentY = 1085
End
Begin FPSpread.vaSpread vassta
Height = 3075
Left = 120
TabIndex = 6
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 = "frmSta.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 = 2415
Left = 120
TabIndex = 0
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 = 1800
MaxLength = 15
TabIndex = 4
Top = 1440
Width = 4095
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 = 1800
MaxLength = 3
TabIndex = 2
Top = 480
Width = 855
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 = 360
TabIndex = 3
Top = 1440
Width = 1095
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 = 480
TabIndex = 1
Top = 480
Width = 1095
End
End
Begin VB.Label lblstatus
Enabled = 0 'False
Height = 255
Left = 8040
TabIndex = 5
Top = 3840
Width = 855
End
End
Attribute VB_Name = "frmSta"
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()
vassta.Width = SpreadW
vassta.Height = SpreadH
lCurRow = 1
lCurRow = 1
Call initspread
Call InitToolBar
Call vasshow
frminput.Enabled = False
End Sub
Private Sub initspread()
With vassta
.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 vassta, True
End Sub
Private Sub SetSpreadHead()
SetColHead vassta, 1, "Reason Code", 14
SetColHead vassta, 2, "Description", 26
End Sub
Private Sub vasshow()
Dim sSQL As String
Dim rststa As Recordset
Dim lrow As Long
sSQL = "select * from syssta"
Set rststa = Acs_cnt.Execute(sSQL)
lrow = 0
vassta.MaxRows = 0
Do While Not rststa.EOF
vassta.MaxRows = vassta.MaxRows + 1
lrow = lrow + 1
SetValue vassta, lrow, 1, rststa!stacode
SetValue vassta, lrow, 2, rststa!stadesc
rststa.MoveNext
Loop
rststa.Close
Set rststa = Nothing
Call vassta_Click(lCurCol, lCurRow)
End Sub
Private Sub InitToolBar()
With UserControl1
.DisplayButton "New", "New", True, , "New"
.DisplayButton "Save", "Save", True, , "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 "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
vassta.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
vassta.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
vassta.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", True, , "Close"
End With
vassta.Enabled = False
frminput.Enabled = True
txtdesc.Enabled = False
txtcode.Enabled = True
txtcode.SetFocus
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
vassta.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 syssta where stacode = '" & sCode & "'"
Set rststa = Acs_cnt.Execute(sSQL)
If Not rststa.EOF Then
txtdesc.Text = rststa!stadesc
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 IniStaDetail
Case "save"
If lblstatus.Caption = "new" Then
If SaveStaInfo = False Then
Exit Sub
End If
ElseIf lblstatus.Caption = "modify" Then
Call ModifyStaInfo
End If
Case "find"
lblstatus.Caption = "search"
Call IniStaDetail
Case "modify"
lblstatus.Caption = mkey
Case "close"
Unload Me
Exit Sub
Case "delete"
If MsgBox("Are you sure to delete this record?", vbYesNo, "Message") = vbYes Then
Call DeleteStaInfo
Call vasshow
Else
Exit Sub
End If
End Select
Call SetToolBar(mkey)
End Sub
Private Sub IniStaDetail()
txtcode.Text = ""
txtdesc.Text = ""
End Sub
Private Sub DeleteStaInfo()
Dim sSQL As String
Dim sCode As String
sCode = txtcode.Text
If sCode = "FRE" Then
MsgBox "The free status can't be deleted!", vbOKOnly, "Information"
Exit Sub
End If
sSQL = "delete from syssta where stacode='" & sCode & "'"
Acs_cnt.BeginTrans
Acs_cnt.Execute (sSQL)
Acs_cnt.CommitTrans
End Sub
Private Sub ModifyStaInfo()
Dim sSQL As String
Dim sCode As String
Dim sdesc As String
sCode = txtcode.Text
sdesc = txtdesc.Text
txtcode.Enabled = False
sSQL = "update syssta set stadesc='" & sdesc & "' where stacode='" & sCode & "'"
Acs_cnt.BeginTrans
Acs_cnt.Execute (sSQL)
Acs_cnt.CommitTrans
End Sub
Private Function SaveStaInfo() As Boolean
Dim sCode As String, sdesc As String
Dim rststa As Recordset
Dim sSQL As String, sRole As String
SaveStaInfo = False
If txtcode.Text <> "" And txtdesc.Text <> "" Then
sCode = Trim(txtcode.Text)
sdesc = Trim(txtdesc.Text)
sSQL = "select * from sysSta where Stacode='" & sCode & "'"
Set rststa = Acs_cnt.Execute(sSQL)
With rststa
If Not .EOF Then
MsgBox "This StaCode is exist,please change the Stacode!", vbInformation, "Error"
Exit Function
End If
End With
sSQL = "insert into sysSta(Stacode,Stadesc)" & " values('" & sCode & "','" & sdesc & "')"
Acs_cnt.BeginTrans
Acs_cnt.Execute (sSQL)
Acs_cnt.CommitTrans
rststa.Close
Set rststa = Nothing
Else
MsgBox "One or Some Items are not input!", vbExclamation, "Error"
Exit Function
End If
SaveStaInfo = True
End Function
Private Sub vassta_Click(ByVal Col As Long, ByVal Row As Long)
Dim lrow As Long
lrow = Row
If Row > 0 Then
txtcode.Text = GetValue(vassta, lrow, 1)
txtdesc.Text = GetValue(vassta, lrow, 2)
End If
End Sub
Private Sub vassta_KeyUp(KeyCode As Integer, Shift As Integer)
Dim lrow, lcol As Long
lrow = vassta.ActiveRow
lcol = vassta.ActiveCol
If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then
Call vassta_Click(lcol, lrow)
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -