www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > frmChange.frm
VERSION 5.00
Begin VB.Form frmChange
BorderStyle = 3 'Fixed Dialog
Caption = "调换班"
ClientHeight = 4335
ClientLeft = 45
ClientTop = 330
ClientWidth = 7035
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmChange.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4335
ScaleWidth = 7035
ShowInTaskbar = 0 'False
StartUpPosition = 1 '所有者中心
Begin VB.Frame Frame1
Height = 1020
Left = 345
TabIndex = 18
Top = 2895
Width = 6330
Begin VB.CommandButton cmdReturn
Caption = "返 回(&R)"
Height = 435
Left = 4815
TabIndex = 22
Top = 360
Width = 1215
End
Begin VB.CommandButton cmdAllow
Caption = "批 准(&A)"
Enabled = 0 'False
Height = 435
Left = 3375
TabIndex = 21
Top = 360
Width = 1215
End
Begin VB.TextBox txtAllow
Height = 330
Left = 1635
TabIndex = 20
Top = 390
Width = 1320
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "调换班批准人:"
Height = 210
Left = 225
TabIndex = 19
Top = 450
Width = 1365
End
End
Begin VB.Frame fraTwo
Height = 2490
Left = 3735
TabIndex = 1
Top = 150
Width = 2955
Begin VB.TextBox txtTwo
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 3
Left = 1140
TabIndex = 17
Top = 1965
Width = 1605
End
Begin VB.TextBox txtTwo
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 2
Left = 1140
TabIndex = 16
Top = 1410
Width = 1605
End
Begin VB.TextBox txtTwo
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 1
Left = 1140
TabIndex = 15
Top = 855
Width = 1605
End
Begin VB.TextBox txtTwo
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 0
Left = 1140
TabIndex = 14
Top = 300
Width = 1605
End
Begin VB.Label lblTwo
AutoSize = -1 'True
Caption = "班 次:"
Height = 210
Index = 3
Left = 285
TabIndex = 9
Top = 2025
Width = 735
End
Begin VB.Label lblTwo
AutoSize = -1 'True
Caption = "日 期:"
Height = 210
Index = 2
Left = 285
TabIndex = 8
Top = 1470
Width = 735
End
Begin VB.Label lblTwo
AutoSize = -1 'True
Caption = "员 工:"
Height = 210
Index = 1
Left = 285
TabIndex = 7
Top = 915
Width = 735
End
Begin VB.Label lblTwo
AutoSize = -1 'True
Caption = "部 门:"
Height = 210
Index = 0
Left = 285
TabIndex = 6
Top = 360
Width = 735
End
End
Begin VB.Frame fraOne
Height = 2490
Left = 330
TabIndex = 0
Top = 150
Width = 2955
Begin VB.TextBox txtOne
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 3
Left = 1095
TabIndex = 13
Top = 1965
Width = 1605
End
Begin VB.TextBox txtOne
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 2
Left = 1095
TabIndex = 12
Top = 1410
Width = 1605
End
Begin VB.TextBox txtOne
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 1
Left = 1095
TabIndex = 11
Top = 855
Width = 1605
End
Begin VB.TextBox txtOne
BackColor = &H00E0E0E0&
Enabled = 0 'False
Height = 330
Index = 0
Left = 1095
TabIndex = 10
Top = 300
Width = 1605
End
Begin VB.Label lblOne
AutoSize = -1 'True
Caption = "班 次:"
Height = 210
Index = 3
Left = 225
TabIndex = 5
Top = 2025
Width = 735
End
Begin VB.Label lblOne
AutoSize = -1 'True
Caption = "日 期:"
Height = 210
Index = 2
Left = 225
TabIndex = 4
Top = 1470
Width = 735
End
Begin VB.Label lblOne
AutoSize = -1 'True
Caption = "员 工:"
Height = 210
Index = 1
Left = 225
TabIndex = 3
Top = 915
Width = 735
End
Begin VB.Label lblOne
AutoSize = -1 'True
Caption = "部 门:"
ForeColor = &H00000000&
Height = 210
Index = 0
Left = 225
TabIndex = 2
Top = 360
Width = 735
End
End
End
Attribute VB_Name = "frmChange"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const OFFSETX = 20
Const OFFSETY = 20
Const OVERCOLOR = &HFFFF& '&H40C0&
Const OUTCOLOR = &H0&
Const MAXCOUNT = 3
Dim mHandIco As Picture
Dim mOldIndex As Integer
'******lblOneTwo
Const mlblDept = 0
Const mlblName = 1
Const mlblDate = 2
Const mlblShift = 3
Const mMsg1 = "只能对当月进行调换班!!请重选日期."
Const mNotDefine = "未定义"
Const mMsg3 = "调换班不能针对同一个人"
Const mMsg2 = "双方班次相同,无调换班的必要!!"
Const mMsg4 = "抱歉,调换班未成功!"
Const mMsg5 = "恭喜,调换班成功!"
Private Sub cmdAllow_Click()
If Trim(txtOne(mlblName).Tag) = Trim(txtTwo(mlblName).Tag) Then
MsgBox mMsg3, vbInformation, gTitle
Exit Sub
End If
Dim OneShift As String
Dim TwoShift As String
OneShift = Trim(txtOne(mlblShift))
TwoShift = Trim(txtTwo(mlblShift))
If OneShift = TwoShift Then
MsgBox mMsg2, vbInformation, gTitle
Exit Sub
End If
Dim OneShiftID As Integer
Dim OneWorkNo As String
Dim OneDay As Integer
Dim OneDate As String
Dim TwoDate As String
Dim TwoDay As Integer
Dim TwoWorkNo As String
Dim TwoShiftID As Integer
Dim IsTrans As Boolean
Dim AllowMan As String
Dim Sql As String
Dim OperateDate As String
On Error GoTo AllowErr
AllowMan = Trim(txtAllow)
OneShiftID = CInt(Val(txtOne(mlblShift).Tag))
TwoShiftID = CInt(Val(txtTwo(mlblShift).Tag))
OneWorkNo = Trim(txtOne(mlblName).Tag)
TwoWorkNo = Trim(txtTwo(mlblName).Tag)
OneDate = Trim(txtOne(mlblDate))
TwoDate = Trim(txtTwo(mlblDate))
OneDay = Day(CDate(OneDate))
TwoDay = Day(CDate(TwoDate))
OperateDate = Format(Date, "yyyy-mm-dd")
BeginTrans
IsTrans = True
Sql = " insert into ChangePlan " _
& "(WorkNo,ChangeDate,AllowMan,OperateMan," _
& "OperateDate,SourceWorkNo) values('" _
& OneWorkNo & "','" & OneDate & "','" _
& AllowMan & "','" & gUserID & "','" _
& OperateDate & "','" & TwoWorkNo & "')"
gDataBase.Execute Sql
Sql = " insert into ChangePlan " _
& "(WorkNo,ChangeDate,AllowMan,OperateMan," _
& "OperateDate,SourceWorkNo) values('" _
& TwoWorkNo & "','" & TwoDate & "','" _
& AllowMan & "','" & gUserID _
& "','" & OperateDate & "','" _
& OneWorkNo & "')"
gDataBase.Execute Sql
Sql = "update " & gPlanTableName & " set F_Shift=" _
& TwoShiftID & " where WorkNo='" & OneWorkNo _
& "' and F_Day=" & OneDay
gDataBase.Execute Sql
Sql = "update " & gPlanTableName & " set F_Shift=" _
& OneShiftID & " where WorkNo='" & TwoWorkNo _
& "' and F_Day=" & TwoDay
gDataBase.Execute Sql
CommitTrans
IsTrans = False
MsgBox mMsg5, vbInformation, gTitle
IniText
Exit Sub
AllowErr:
If IsTrans Then Rollback
MsgBox mMsg4 & vbCrLf & vbCrLf _
& Err.Description, vbExclamation, gTitle
Err.Clear
End Sub
Private Sub IniText()
Dim I As Integer
For I = 0 To txtOne.Count - 1
txtOne(I) = Empty
txtOne(I).Tag = Empty
Next
For I = 0 To txtTwo.Count - 1
txtTwo(I) = Empty
txtOne(I).Tag = Empty
Next
txtAllow = Empty
End Sub
Private Sub cmdReturn_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim Str As String
Str = App.Path & "/Data/Hand.ico"
If Dir(Str) <> Empty Then
Set mHandIco = LoadPicture(Str)
Else
Set mHandIco = Nothing
End If
SetIco
' Dim Str As String
' Str = App.Path + "\data\kq.mdb"
' Set gDataBase = Workspaces(0).OpenDatabase(Str, False, False, ";pwd=wsh2000")
' SetPlanTableName
' gUserID = "Wsh"
End Sub
Private Sub SetIco()
Dim I As Integer
For I = 0 To lblOne.Count - 2
lblOne(I).MousePointer = 99
Set lblOne(I).MouseIcon = mHandIco
Next
For I = 0 To lblTwo.Count - 2
lblTwo(I).MousePointer = 99
Set lblTwo(I).MouseIcon = mHandIco
Next
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
OutMouseMove
End Sub
Private Sub OutMouseMove()
If lblOne(mOldIndex).ForeColor = OVERCOLOR Then
With lblOne(mOldIndex)
.ForeColor = OUTCOLOR
.Left = .Left - OFFSETX
.Top = .Top - OFFSETY
End With
End If
If lblTwo(mOldIndex).ForeColor = OVERCOLOR Then
With lblTwo(mOldIndex)
.ForeColor = OUTCOLOR
.Left = .Left - OFFSETX
.Top = .Top - OFFSETY
End With
End If
mOldIndex = MAXCOUNT
End Sub
Private Sub MouseMove(lblTemp As Label, Index As Integer)
If Index = lblOne.Count - 1 Then Exit Sub
If mOldIndex = Index Then Exit Sub
With lblTemp
.Left = .Left + OFFSETX
.Top = .Top + OFFSETY
.ForeColor = OVERCOLOR
End With
mOldIndex = Index
End Sub
Private Sub fraOne_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
OutMouseMove
End Sub
Private Sub fraTwo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
OutMouseMove
End Sub
Private Sub lblOne_Click(Index As Integer)
If Index = mlblShift Then Exit Sub
Select Case Index
Case mlblDept, mlblName
Dim MyfrmLookMan As frmLookMan
Set MyfrmLookMan = New frmLookMan
With MyfrmLookMan
.Show vbModal
txtOne(mlblDept) = .mDept
txtOne(mlblName) = .mName
txtOne(mlblName).Tag = .mWorkNo
End With
Unload MyfrmLookMan
Case mlblDate
lblDateClick txtOne(Index)
End Select
ShowShift txtOne(mlblName), txtOne(mlblDate), txtOne(mlblShift)
End Sub
Private Sub lblOne_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
MouseMove lblOne(Index), Index
End Sub
Private Sub lblTwo_Click(Index As Integer)
If Index = mlblShift Then Exit Sub
Select Case Index
Case mlblDept, mlblName
Dim MyfrmLookMan As frmLookMan
Set MyfrmLookMan = New frmLookMan
With MyfrmLookMan
.Show vbModal
txtTwo(mlblDept) = .mDept
txtTwo(mlblName) = .mName
txtTwo(mlblName).Tag = .mWorkNo
End With
Unload MyfrmLookMan
Case mlblDate
lblDateClick txtTwo(Index)
End Select
ShowShift txtTwo(mlblName), txtTwo(mlblDate), txtTwo(mlblShift)
End Sub
Private Sub ShowShift(txtName As TextBox, txtDate As TextBox, txtShift As TextBox)
If Trim(txtName) = Empty Or Trim(txtDate) = Empty Then Exit Sub
DateErr:
Dim DateIsValid As Boolean
If Month(CDate(txtDate)) <> Month(Date) Then
DateIsValid = False
Else
DateIsValid = True
End If
If Not DateIsValid Then
MsgBox mMsg1, vbCritical, gTitle
lblDateClick txtDate
GoTo DateErr
Exit Sub
End If
Dim strWorkNo As String
Dim intDay As Integer
Dim Rst As Recordset
Dim Sql As String
txtShift = ""
strWorkNo = Trim(txtName.Tag)
intDay = Day(CDate(txtDate))
Sql = "select ID,ShiftName from " & gPlanQryName & " where " _
& " WorkNo='" & strWorkNo & "' and F_Day=" _
& intDay
Set Rst = gDataBase.OpenRecordset(Sql, dbOpenSnapshot)
If Rst.RecordCount > 0 Then
If Rst!ID = gNoShift Then
txtShift = mNotDefine
txtShift.Tag = gNoShift
Else
txtShift = IIf(IsNull(Rst!ShiftName), mNotDefine, Trim(Rst!ShiftName))
txtShift.Tag = Rst!ID
End If
End If
Rst.Close
Set Rst = Nothing
End Sub
Private Sub lblTwo_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
MouseMove lblTwo(Index), Index
End Sub
Private Sub lblDateClick(lblTemp As TextBox)
Dim myfrmRiLi As frmRiLi
Set myfrmRiLi = New frmRiLi
With myfrmRiLi
.Show vbModal
If .mRetDate <> Empty Then
lblTemp = .mRetDate
End If
End With
Unload myfrmRiLi
End Sub
Private Sub txtAllow_Change()
cmdAllow.Enabled = (Trim(txtAllow) <> Empty)
End Sub