www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > frmItem.frm
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmItem
BorderStyle = 3 'Fixed Dialog
Caption = "项目管理"
ClientHeight = 3720
ClientLeft = 45
ClientTop = 330
ClientWidth = 5715
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmItem.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3720
ScaleWidth = 5715
ShowInTaskbar = 0 'False
StartUpPosition = 1 '所有者中心
Begin VB.TextBox txtEdit
Height = 345
Left = 690
TabIndex = 10
Top = 1695
Visible = 0 'False
Width = 1185
End
Begin VB.Frame fraName
Height = 930
Left = 2910
TabIndex = 8
Top = 975
Width = 2565
Begin VB.TextBox txtName
Height = 360
Left = 960
TabIndex = 1
Top = 345
Width = 1395
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "名 称:"
Height = 210
Left = 180
TabIndex = 9
Top = 420
Width = 630
End
End
Begin VB.ComboBox cboTable
Height = 330
Left = 2910
Style = 2 'Dropdown List
TabIndex = 0
Top = 510
Width = 2565
End
Begin VB.Frame fraCmd
Height = 1440
Left = 2910
TabIndex = 6
Top = 2040
Width = 2565
Begin VB.CommandButton cmdEdit
Enabled = 0 'False
Height = 435
Index = 3
Left = 120
Picture = "frmItem.frx":000C
Style = 1 'Graphical
TabIndex = 2
Top = 270
Width = 1140
End
Begin VB.CommandButton cmdEdit
Height = 435
Index = 2
Left = 1350
Picture = "frmItem.frx":1DAB
Style = 1 'Graphical
TabIndex = 5
Top = 840
Width = 1140
End
Begin VB.CommandButton cmdEdit
Enabled = 0 'False
Height = 435
Index = 1
Left = 120
Picture = "frmItem.frx":3C1C
Style = 1 'Graphical
TabIndex = 4
Top = 840
Width = 1140
End
Begin VB.CommandButton cmdEdit
Enabled = 0 'False
Height = 435
Index = 0
Left = 1350
Picture = "frmItem.frx":5A1C
Style = 1 'Graphical
TabIndex = 3
Top = 270
Width = 1140
End
End
Begin MSFlexGridLib.MSFlexGrid msfGrid
Height = 3300
Left = 285
TabIndex = 7
Top = 210
Width = 2370
_ExtentX = 4180
_ExtentY = 5821
_Version = 393216
Cols = 1
FixedCols = 0
FormatString = "<名 称 "
End
Begin VB.Label Label2
Caption = "请选择表名:"
Height = 270
Left = 2940
TabIndex = 11
Top = 225
Width = 1170
End
End
Attribute VB_Name = "frmItem"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mTableName As String
Dim mRst As Recordset
Dim mSql As String
Dim mOldName As String
Private Type ItemStruc
ID As Long
TableName As String
Alias As String
End Type
Dim mATable() As ItemStruc
'*****cmdEdit
Const mAPPEND = 3
Const mDELETE = 0
Const mSAVE = 1
Const mRETURN = 2
'******msfGrid
Const mGridName = 0
Const mGRIDID = 1
Const mGRIDLOG = 2
Const mFormatString = "<名 称 | msfGrid.FixedRows)
End Sub
Private Sub cboTable_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then
SendKeyTab KeyCode
End If
End Sub
Private Sub cmdEdit_Click(Index As Integer)
Select Case Index
Case mAPPEND
AppendData
Case mSAVE
SaveData
Case mDELETE
DeleteData
cmdEdit(mDELETE).Enabled = (msfGrid.Rows > msfGrid.FixedRows)
Case mRETURN
If cmdEdit(mSAVE).Enabled Then
If MsgBox(gMsg8, vbQuestion + vbYesNo, gTitle) = vbYes Then
SaveData
End If
End If
Unload Me
End Select
End Sub
Private Sub SaveData()
With msfGrid
If Not ValidTableName Then Exit Sub
Dim I As Integer
Dim strName As String
Dim lngID As Long
Dim intLog As Integer
On Error GoTo SaveErr
For I = .FixedRows To .Rows - 1
intLog = CInt(.TextMatrix(I, mGRIDLOG))
If intLog = gTRUE Then
lngID = Val(.TextMatrix(I, mGRIDID))
strName = Trim(.TextMatrix(I, mGridName))
mSql = " Update " & mTableName _
& " set Name='" & strName & "'" _
& " where ID=" & lngID
gDataBase.Execute mSql
.TextMatrix(I, mGRIDLOG) = gFALSE
End If
Next
End With
cmdEdit(mSAVE).Enabled = False
Exit Sub
SaveErr:
MsgBox gMsg5 & vbCrLf & Err.Description, vbExclamation, gTitle
Err.Clear
End Sub
Private Sub DeleteData()
Dim IsTrans As Boolean
With msfGrid
If .Rows <= .FixedRows Then Exit Sub
If .row < .FixedRows Then
MsgBox gMsg4, vbExclamation, gTitle
Exit Sub
End If
Dim tmpStr As String
' If mTableName = "Title" Then
' tmpStr = mMsg3
' ElseIf mTableName = "LeaveType" Then
' tmpStr = mMsg4
' ElseIf mTableName = "Department" Then
' tmpStr = mMsg5
' End If
'
' If MsgBox(tmpStr, vbQuestion + vbOKCancel _
' + vbDefaultButton2, gTitle) = vbCancel Then Exit Sub
If MsgBox(gMsg10, vbOKCancel + vbQuestion + vbDefaultButton2) = vbCancel Then Exit Sub
Dim lngID As Long
lngID = Val(.TextMatrix(.row, mGRIDID))
If mTableName = "Title" Then
mSql = "select * from Employee where TitleID=" _
& lngID & " order by WorkNo"
ElseIf mTableName = "LeaveType" Then
mSql = "select * from Leave where TypeId=" _
& lngID & " order by WorkNo"
ElseIf mTableName = "Department" Then
mSql = "select * from Employee where DeptID=" _
& lngID & " order by WorkNo"
End If
Set mRst = gDataBase.OpenRecordset(mSql)
If mRst.RecordCount > 0 Then
If mTableName = "Title" Then
tmpStr = mMsg3
ElseIf mTableName = "LeaveType" Then
tmpStr = mMsg4
ElseIf mTableName = "Department" Then
tmpStr = mMsg5
End If
MsgBox tmpStr, vbExclamation, gTitle
Exit Sub
End If
If Not ValidTableName Then Exit Sub
On Error GoTo DeleteErr
BeginTrans
IsTrans = True
' If mTableName = "LeaveType" Then
' mSql = "update " & "Leave" & _
' " set F_DelFlag=" & gTRUE _
' & " Where TypeID=" & lngID
' ElseIf mTableName = "Title" Then
' mSql = "update " & "Employee" & _
' " set F_DelFlag=" & gTRUE _
' & " Where TitleID=" & lngID
' ElseIf mTableName = "Department" Then
' mSql = "update " & "Employee" & _
' " set F_DelFlag=" & gTRUE _
' & " Where DeptID=" & lngID
' End If
' gDataBase.Execute mSql
mSql = "update " & mTableName & _
" set F_DelFlag=" & gTRUE _
& " Where ID=" & lngID
gDataBase.Execute mSql
CommitTrans
IsTrans = False
If .Rows = .FixedRows + 1 Then
.Rows = .FixedRows
Else
.RemoveItem .row
End If
End With
mSql = ""
Exit Sub
DeleteErr:
If IsTrans Then Rollback
MsgBox gMsg6 & vbCrLf & Err.Description, vbExclamation, gTitle
Err.Clear
End Sub
Private Function ValidTableName() As Boolean
ValidTableName = True
If mTableName = "" Then
MsgBox mMsg2, vbInformation, gTitle
cboTable.SetFocus
ValidTableName = False
Exit Function
End If
End Function
Private Sub AppendData()
Dim strName As String
strName = Trim(txtName)
If strName = Empty Then
MsgBox mMsg1, vbInformation, gTitle
txtName.SetFocus
Exit Sub
End If
If Not ValidTableName Then Exit Sub
On Error GoTo AppendErr
mSql = " select * from " & mTableName _
& " where Name='" & strName & "'" _
& " and F_DelFlag=" & gFALSE
Set mRst = gDataBase.OpenRecordset(mSql)
If mRst.RecordCount > 0 Then
MsgBox gMsg3, vbExclamation, gTitle
txtName.SetFocus
Exit Sub
End If
mSql = "Insert into " & mTableName & "(Name)" _
& " values('" & strName & "')"
gDataBase.Execute mSql
RefreshGrid mTableName
txtName = ""
txtName.SetFocus
Exit Sub
AppendErr:
MsgBox gMsg7 & vbCrLf & Err.Description, vbExclamation, gTitle
Err.Clear
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim AltDown As Boolean
AltDown = (Shift And vbAltMask) > 0
If AltDown Then
Select Case KeyCode
Case vbKeyA
cmdEdit_Click mAPPEND
Case vbKeyS
cmdEdit_Click mSAVE
Case vbKeyD
cmdEdit_Click mDELETE
Case vbKeyR
cmdEdit_Click mRETURN
End Select
End If
If KeyCode = vbKeyF2 Then
cmdEdit_Click mSAVE
End If
If KeyCode = 27 Then
cmdEdit_Click mRETURN
End If
End Sub
Private Sub Form_Load()
IniForm
IniCbo
End Sub
Private Function GetTableName(IntID As Long) As String
GetTableName = Empty
Dim I As Integer
For I = 0 To UBound(mATable)
If mATable(I).ID = IntID Then
GetTableName = Trim(mATable(I).TableName)
Exit For
End If
Next
End Function
Private Sub IniCbo()
ReDim mATable(0)
Dim IntLen As Integer
mATable(0).ID = 0
mSql = "select F_ID,F_TableName,F_ItemName from T_Struct order by F_ID "
Set mRst = gDataBase.OpenRecordset(mSql, dbOpenSnapshot)
While Not mRst.EOF
IntLen = UBound(mATable)
IntLen = IntLen + 1
ReDim Preserve mATable(IntLen)
With mATable(IntLen)
.ID = mRst!F_ID
.TableName = IIf(IsNull(mRst!F_TableName), "", Trim(mRst!F_TableName))
.Alias = IIf(IsNull(mRst!F_ItemName), "", Trim(mRst!F_ItemName))
End With
mRst.MoveNext
Wend
mRst.Close
Set mRst = Nothing
Dim I As Integer
If UBound(mATable) > 0 Then
For I = 1 To UBound(mATable)
With mATable(I)
cboTable.AddItem .Alias
cboTable.ItemData(cboTable.NewIndex) = .ID
End With
Next
cboTable.ListIndex = 0
End If
cmdEdit(mAPPEND).Enabled = (cboTable.ListCount > 0)
End Sub
Private Sub msfGrid_DblClick()
With msfGrid
If .MouseRow = 0 Then Exit Sub
If .Rows <= .FixedRows Then Exit Sub
mOldName = Trim(.TextMatrix(.row, mGridName))
SetTxtPosition msfGrid, txtEdit
End With
End Sub
Private Sub msfGrid_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then
msfGrid_DblClick
End If
End Sub
Private Sub txtEdit_GotFocus()
GotFocus txtEdit
End Sub
Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyReturn
Dim strName As String
strName = Trim(txtEdit)
If strName = Empty Then Exit Sub
txtEdit.Visible = False
If mOldName <> strName Then
With msfGrid
.TextMatrix(.row, mGridName) = strName
.TextMatrix(.row, mGRIDLOG) = gTRUE
End With
If Not cmdEdit(mSAVE).Enabled Then cmdEdit(mSAVE).Enabled = True
End If
msfGrid.SetFocus
Case vbKeyDown, vbKeyUp
txtEdit.Visible = False
KeyDownByUpDown msfGrid, KeyCode
msfGrid.SetFocus
End Select
End Sub
Private Sub txtEdit_LostFocus()
txtEdit.Visible = False
End Sub
Private Sub txtName_GotFocus()
GotFocus txtName
End Sub
Private Sub txtName_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then
SendKeyTab KeyCode
End If
End Sub