www.pudn.com > VB-KAOQINXITONG.zip > frmWorkTimeSet.frm
VERSION 5.00
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "Tabctl32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{B9D938CE-50EE-40B2-9FA2-79A3112F4788}#4.2#0"; "BNCtrlGroup.ocx"
Begin VB.Form frmWorkTimeSet
ClientHeight = 7455
ClientLeft = 975
ClientTop = 420
ClientWidth = 10545
Icon = "frmWorkTimeSet.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
ScaleHeight = 7455
ScaleWidth = 10545
StartUpPosition = 2 '屏幕中心
Begin VB.CheckBox chkAddLast
Alignment = 1 'Right Justify
Appearance = 0 'Flat
Caption = "加班尾卡:"
ForeColor = &H80000008&
Height = 210
Left = 7740
TabIndex = 38
Top = 5025
Width = 1170
End
Begin VB.Frame Frame3
Appearance = 0 'Flat
Caption = " 班次描述: "
ForeColor = &H80000008&
Height = 1575
Left = 7890
TabIndex = 36
Top = 5400
Width = 2490
Begin VB.TextBox txtDesc
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
ForeColor = &H00FF0000&
Height = 1140
Left = 165
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 37
Top = 300
Width = 2190
End
End
Begin MSComctlLib.TreeView TreeView1
Height = 5490
Left = 5010
TabIndex = 31
Top = 870
Visible = 0 'False
Width = 2100
_ExtentX = 3704
_ExtentY = 9684
_Version = 393217
LabelEdit = 1
Style = 4
BorderStyle = 1
Appearance = 0
End
Begin BNCtrlGroup.BNButton cmdAdd
Height = 375
Left = 9045
TabIndex = 8
Top = 570
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "添 加"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin BNCtrlGroup.BNButton cmdDelete
Height = 375
Left = 9075
TabIndex = 9
Top = 1095
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "删 除"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin BNCtrlGroup.BNButton cmdEdit
Height = 375
Left = 9075
TabIndex = 10
Top = 1620
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "编 辑"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin BNCtrlGroup.BNButton cmdCancel
Height = 375
Left = 9075
TabIndex = 11
Top = 2130
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "取 消"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin BNCtrlGroup.BNButton cmdExit
Cancel = -1 'True
Height = 375
Left = 9090
TabIndex = 13
Top = 4425
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "退 出"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin BNCtrlGroup.BNButton cmdSave
Height = 375
Left = 9090
TabIndex = 12
Top = 2715
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "保 存"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin VB.Frame Frame2
Appearance = 0 'Flat
ForeColor = &H80000008&
Height = 1575
Left = 3285
TabIndex = 24
Top = 5400
Width = 4545
Begin VB.TextBox txtClassTime
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Left = 3427
MaxLength = 8
TabIndex = 41
Top = 716
Width = 975
End
Begin VB.TextBox txtMustAdd
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Left = 1110
MaxLength = 8
TabIndex = 39
Top = 1155
Width = 975
End
Begin VB.TextBox txtHours
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Left = 3427
MaxLength = 8
TabIndex = 6
Top = 278
Width = 975
End
Begin VB.TextBox txtCode
Appearance = 0 'Flat
BackColor = &H00C0FFFF&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 1110
MaxLength = 3
TabIndex = 16
TabStop = 0 'False
Top = 278
Width = 975
End
Begin VB.TextBox txtClass
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 1110
MaxLength = 8
TabIndex = 7
Top = 716
Width = 975
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "正班工时:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 7
Left = 2520
TabIndex = 42
Top = 780
Width = 765
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "额定加班:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 4
Left = 180
TabIndex = 40
Top = 1200
Width = 765
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "排班颜色:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Index = 24
Left = 2505
TabIndex = 30
Top = 1222
Width = 810
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "班次序号："
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 0
Left = 120
TabIndex = 29
Top = 4860
Visible = 0 'False
Width = 975
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H00FFFFFF&
BackStyle = 0 'Transparent
Caption = "字体颜色"
DataField = "Color"
Height = 270
Left = 3435
TabIndex = 28
Tag = "A1,Color"
ToolTipText = "颜色"
Top = 1215
Width = 975
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "标准工时:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Index = 6
Left = 2467
TabIndex = 27
Top = 345
Width = 810
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "排班代号:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Index = 38
Left = 135
TabIndex = 26
Top = 345
Width = 810
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "班次代码:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Index = 39
Left = 135
TabIndex = 25
Top = 772
Width = 810
End
Begin VB.Shape shpColor
BackColor = &H00FFFFFF&
BackStyle = 1 'Opaque
Height = 270
Left = 3427
Top = 1177
Width = 990
End
End
Begin MSComctlLib.TreeView TreeList
Height = 6855
Left = 105
TabIndex = 14
Top = 120
Width = 3105
_ExtentX = 5477
_ExtentY = 12091
_Version = 393217
Style = 7
BorderStyle = 1
Appearance = 0
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 20
Top = 7080
Width = 10545
_ExtentX = 18600
_ExtentY = 661
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 18098
EndProperty
EndProperty
End
Begin BNCtrlGroup.BNComboBox cobHourKindID
Height = 300
Left = 5175
TabIndex = 5
Top = 4965
Width = 1740
_ExtentX = 0
_ExtentY = 0
BackColor = 14737632
BackColor = 14737632
BackColor = 14737632
End
Begin VB.TextBox txtHourKindID
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
ForeColor = &H00FF0000&
Height = 300
IMEMode = 3 'DISABLE
Left = 4095
Locked = -1 'True
MaxLength = 1
TabIndex = 18
TabStop = 0 'False
Top = 4965
Width = 1050
End
Begin VB.Frame Frame1
BorderStyle = 0 'None
Height = 5400
Index = 4
Left = 3150
TabIndex = 21
Top = -450
Width = 5865
Begin VB.CheckBox chkSpeCard
Appearance = 0 'Flat
BackColor = &H00FFFFC0&
ForeColor = &H80000008&
Height = 195
Index = 1
Left = 1980
TabIndex = 47
Top = 1785
Visible = 0 'False
Width = 270
End
Begin VB.TextBox txtAdjEnd
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Index = 1
Left = 4650
Locked = -1 'True
MaxLength = 8
TabIndex = 46
Top = 1905
Width = 975
End
Begin VB.TextBox txtAdjBgn
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Index = 0
Left = 0
MaxLength = 8
TabIndex = 45
Top = 0
Width = 975
End
Begin TabDlg.SSTab SSTab1
Height = 495
Left = 195
TabIndex = 44
Top = 585
Width = 5580
_ExtentX = 9843
_ExtentY = 873
_Version = 393216
Tabs = 2
TabHeight = 520
TabCaption(0) = "基本设置"
TabPicture(0) = "frmWorkTimeSet.frx":000C
Tab(0).ControlEnabled= -1 'True
Tab(0).ControlCount= 0
TabCaption(1) = "其他设置"
TabPicture(1) = "frmWorkTimeSet.frx":0028
Tab(1).ControlEnabled= 0 'False
Tab(1).ControlCount= 0
End
Begin VB.TextBox txtAdjBgn
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Index = 1
Left = 4635
MaxLength = 8
TabIndex = 35
Top = 1523
Width = 975
End
Begin VB.TextBox txtAdjustHours
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Index = 1
Left = 3840
TabIndex = 34
Top = 1725
Width = 660
End
Begin VB.TextBox txtCardRange2
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Index = 1
Left = 2295
TabIndex = 2
Top = 1523
Width = 420
End
Begin VB.CheckBox chkIsAdd
Appearance = 0 'Flat
BackColor = &H00FFFFC0&
ForeColor = &H80000008&
Height = 195
Index = 1
Left = 3405
TabIndex = 4
Top = 1785
Width = 270
End
Begin VB.TextBox txtWorkTime
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
ForeColor = &H00FF0000&
Height = 285
IMEMode = 3 'DISABLE
Index = 1
Left = 855
TabIndex = 0
Top = 1538
Width = 840
End
Begin VB.TextBox txtCardRange1
Appearance = 0 'Flat
BackColor = &H00E0E0E0&
ForeColor = &H00FF0000&
Height = 315
IMEMode = 3 'DISABLE
Index = 1
Left = 1845
TabIndex = 1
Top = 1523
Width = 420
End
Begin VB.CheckBox chkIsOver
Appearance = 0 'Flat
BackColor = &H00FFFFC0&
Caption = "2"
ForeColor = &H80000008&
Height = 210
Index = 1
Left = 2925
TabIndex = 3
Top = 1575
Width = 285
End
Begin VB.Line Line2
BorderColor = &H00FF0000&
Index = 1
X1 = 195
X2 = 5745
Y1 = 1440
Y2 = 1440
End
Begin VB.Label lblCpt
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "调整工时及起始时刻"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 5
Left = 3900
TabIndex = 33
Top = 1200
Width = 1620
End
Begin VB.Label lblCpt
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "标准打卡时刻"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 1
Left = 450
TabIndex = 32
Top = 1200
Width = 1080
End
Begin VB.Line Line1
BorderColor = &H00FF0000&
Index = 0
X1 = 1755
X2 = 1755
Y1 = 1095
Y2 = 5250
End
Begin VB.Label lblCaption
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "上班"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Index = 1
Left = 390
TabIndex = 23
Top = 1560
Width = 360
End
Begin VB.Label lblCpt
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "打卡范围"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 2
Left = 1890
TabIndex = 22
Top = 1200
Width = 720
End
Begin VB.Label lblCpt
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "跨天"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 3
Left = 2865
TabIndex = 15
Top = 1200
Width = 360
End
Begin VB.Label lblCpt
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "加班"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Index = 4
Left = 3360
TabIndex = 17
Top = 1200
Width = 360
End
Begin VB.Shape Shape2
BackColor = &H00FFFFC0&
BackStyle = 1 'Opaque
BorderStyle = 0 'Transparent
Height = 855
Index = 1
Left = 210
Top = 1455
Width = 5550
End
Begin VB.Shape Shape1
BackColor = &H8000000F&
BackStyle = 1 'Opaque
BorderColor = &H00FF0000&
Height = 4185
Left = 195
Top = 1080
Width = 5580
End
End
Begin BNCtrlGroup.BNButton cmdSearch
Height = 375
Left = 9090
TabIndex = 43
Top = 3300
Width = 1305
_ExtentX = 2302
_ExtentY = 661
Caption = "查 找"
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
cBack = -2147483633
End
Begin VB.Label lblLabels
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "班次种类:"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 180
Index = 3
Left = 3255
TabIndex = 19
Top = 5055
Width = 810
End
End
Attribute VB_Name = "frmWorkTimeSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'2002-4-15:
' 修改了自动签卡的BUG
' 将打卡的前后误差范围分别进行了定义
' 修改了调整工时设置时的BUG
Option Explicit
Private WithEvents madoWkTmRS As ADODB.Recordset
Attribute madoWkTmRS.VB_VarHelpID = -1
Dim mbChangedByCode As Boolean
Dim mbEditFlag As Boolean
Dim mbAddNewFlag As Boolean
Dim mbDataChanged As Boolean
Dim mbFirstRun As Boolean
Dim mlID As Long
Dim msClassID As String
Dim msCode As String
Dim mbIsBusy As Boolean
Dim mvBookMark
Dim mbDisabled As Boolean
Dim mbDisabled1 As Boolean
Dim mbDisabled3 As Boolean
Dim mNode As MSComctlLib.Node
Private Sub cmdSearch_Click()
Dim sClassID As String
Dim oNode As MSComctlLib.Node
' On Error Resume Next
Me.Hide
sClassID = gclsInclude.MyInputBox("请输入须定位的班次代码", "查找班次")
Me.Show
If sClassID <> "" Then
sClassID = UCase(sClassID)
madoWkTmRS.Filter = "E6699 = '" & sClassID & "'"
If madoWkTmRS.RecordCount = 0 Then
MsgBox "未查找到编号为" & sClassID & "的班次!", vbExclamation
Else
'选中树节点
For Each oNode In TreeList.Nodes
If UCase(gclsInclude.MyGetSerialStr(oNode.Tag, 3)) = sClassID Then
oNode.Selected = True
TreeList.SetFocus
Exit For
End If
Next
End If
End If
End Sub
Private Sub madoWkTmRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
If mbIsBusy Then Exit Sub
Dim i As Integer
If mbDisabled1 Then Exit Sub
If madoWkTmRS.EOF Or madoWkTmRS.BOF Then
Exit Sub
Else
cmdEdit.Enabled = True
End If
If madoWkTmRS.RecordCount > 0 Then
LoShowValue True
Else
LoShowValue False
End If
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cobHourKindID_Click()
If mbDisabled3 Then Exit Sub
txtHourKindID.Text = gclsCommon.CBNGetFirstData(cobHourKindID.Text)
End Sub
Private Sub Form_Click()
StatusBar1.Panels(1).Text = ""
If TreeView1.Visible Then TreeView1.Visible = False
End Sub
Private Sub LoShowValue(ByVal fbFlag As Boolean)
Dim oControl As Control
Dim i As Integer
Dim sinTemp As Single
With madoWkTmRS
For Each oControl In Controls
' Debug.Print TypeName(oControl)
Select Case TypeName(oControl)
Case "BNComboBox"
'txtHourKindID.DataField = "C6689"
If gclsInclude.MyNz(.Fields("C6689"), False) = False Then
oControl.ListIndex = 3
Else
i = .Fields("C6689")
If i <= oControl.ListCount Then
oControl.ListIndex = i
Else
oControl.ListIndex = 3
End If
End If
Case "CheckBox"
If Len(oControl.DataField) > 0 Then
If fbFlag Then
If gclsInclude.MyNz(.Fields(oControl.DataField), False) = False Then
oControl.Value = 0
Else
oControl.Value = 1
End If
Else
If mbAddNewFlag Then
If oControl.Name = "chkAddLast" Then
oControl.Value = 1
Else
oControl.Value = IIf(fbFlag, 1, 0)
End If
Else
oControl.Value = IIf(fbFlag, 1, 0)
End If
End If
End If
Case "TextBox"
If Len(oControl.DataField) > 0 Then
If fbFlag Then
If oControl.Name = "txtWorkTime" Then
oControl = gclsInclude.MyNz(.Fields(oControl.DataField), "")
ElseIf oControl.Name = "txtAdjBgn" Then
If IsDate(gclsInclude.MyNz(.Fields(oControl.DataField), 0)) Then
sinTemp = gclsInclude.MyNz(.Fields("C667" & (5 + oControl.Index)).Value, 0)
If sinTemp <> 0 Then
oControl = gclsInclude.MyNz(.Fields(oControl.DataField), 0)
txtAdjEnd(oControl.Index) = DateAdd("n", Abs(sinTemp * 60), CDate(.Fields(oControl.DataField)))
Else
oControl = ""
txtAdjEnd(oControl.Index) = ""
End If
Else
oControl = ""
txtAdjEnd(oControl.Index) = ""
End If
ElseIf oControl.Name = "txtClassTime" Then
oControl = gclsInclude.MyNz(.Fields(oControl.DataField), 0)
If oControl = "0" Then
oControl = gclsInclude.MyNz(.Fields("C6673"), 0)
End If
ElseIf oControl.Name = "txtHourKindID" Then
Else
oControl = gclsInclude.MyNz(.Fields(oControl.DataField), 0)
End If
Else
Select Case oControl.Name
Case "txtWorkTime"
oControl = "00:00:00"
Case "txtCardRange1", "txtCardRange2", "txtAdjustHours"
oControl = "0"
Case "txtHours"
oControl = 8
Case "txtClassTime"
oControl = 8
Case "txtMustAdd"
oControl = 0
Case "txtAdjBgn", "txtAdjEnd"
oControl = 0
Case "txtHourKindID"
i = 3
Case Else
oControl = ""
End Select
End If
End If
End Select
Next
If fbFlag Then
lblColor.ForeColor = gclsInclude.MyNz(!W6680, 0)
Else
lblColor.ForeColor = 0
End If
If lblColor.ForeColor < 0 Then
lblColor.ForeColor = 0
End If
shpColor.BackColor = &HFFFFFF - lblColor.ForeColor
End With
End Sub
Private Function LoSetValue() As String
Dim oControl As Control
Dim DDate As Date
Dim sValue As String
Dim i As Integer
On Error GoTo ErrLabel
gDBRecordConn.BeginTrans
For i = 1 To CLASS_SEC
If Len(txtAdjustHours(i)) = 0 Then txtAdjustHours(i) = 0
If txtAdjustHours(i) = 0 Then
txtAdjBgn(i) = 0
txtAdjEnd(i) = 0
End If
Next i
If Len(txtHours) = 0 Then txtHours = 0
If Len(txtMustAdd) = 0 Then txtMustAdd = 0
If Len(txtHourKindID) = 0 Then txtHourKindID = 0
With madoWkTmRS
For Each oControl In Controls
Select Case TypeName(oControl)
Case "CheckBox", "TextBox"
If Len(oControl.DataField) > 0 Then
If IsNull(madoWkTmRS.Fields(oControl.DataField)) Or (Trim(oControl) <> Trim(madoWkTmRS.Fields(oControl.DataField))) Or mbAddNewFlag Then
If gclsDBFunc.dbGetFieldType(madoWkTmRS.Fields(oControl.DataField).Type) = "Date" Then
DDate = CDate(oControl)
If IsNull(madoWkTmRS.Fields(oControl.DataField)) Or (madoWkTmRS.Fields(oControl.DataField) <> DDate) Or mbAddNewFlag Then
madoWkTmRS.Fields(oControl.DataField) = IIf(CDate(oControl) = 0, Null, CDate(oControl))
End If
Else
madoWkTmRS.Fields(oControl.DataField) = oControl
End If
End If
End If
End Select
Next
If mbAddNewFlag Or IsNull(!W6680) Or (!W6680 <> lblColor.ForeColor) Then !W6680 = lblColor.ForeColor
If mbAddNewFlag Or IsNull(!W0093) Or (!W0093 <> "WC") Then !W0093 = "WC"
If mbAddNewFlag Or IsNull(!W0090) Or (!W0090 <> Left(!W6681, 1) & "00") Then !W0090 = Left(!W6681, 1) & "00"
If mbAddNewFlag Or IsNull(!W0091) Or (!W0091 <> 0) Then !W0091 = 0
For i = 1 To CLASS_SEC
If Val(txtAdjustHours(i).Text) < 0 Then
DDate = CDate(txtAdjBgn(i))
DDate = DateAdd("n", Abs(Val(txtAdjustHours(i).Text) * 60), DDate)
txtAdjEnd(i) = Format(DDate, "HH:NN:SS")
Else
txtAdjEnd(i) = txtAdjBgn(i)
End If
Next i
If mbAddNewFlag Or IsNull(!ID) Or (!ID <> mlID) Then !ID = mlID
.Update
gDBRecordConn.CommitTrans
LoSetValue = ""
End With
Exit Function
ErrLabel:
If Err = -2147467259 Then
LoSetValue = "查询过于复杂,数据无法保存,请联系软件供应商"
Else
LoSetValue = Error
End If
gDBRecordConn.RollbackTrans
Err.Clear
End Function
Private Sub LoSetDataField()
Dim i As Integer
txtClass.DataField = "E6699"
txtClass.ToolTipText = "班次代码最多为8位且不作限制"
txtDesc.DataField = "C6672"
txtDesc.ToolTipText = "对本班次的简要描述"
txtHours.DataField = "C6673"
txtHours.ToolTipText = "每天工作的有效时间.建议选择8小时"
txtClassTime.DataField = "C6680"
txtClassTime.ToolTipText = "每天必须工作时间.低于该工时为缺勤,一般情况下等于标准工时"
txtHourKindID.DataField = "C6689"
txtHourKindID.ToolTipText = "建议选择3"
txtMustAdd.DataField = "C6674"
txtMustAdd.ToolTipText = "每天必需的加班时间,超过此加班时间的为额外加班(小时)"
For i = 1 To CLASS_SEC
txtAdjBgn(i).DataField = "C6611"
txtAdjBgn(i).DataField = "C661" & i
txtAdjEnd(i).DataField = ""
txtAdjustHours(i).DataField = "C667" & 5 + i
txtAdjEnd(i).Locked = True
txtAdjBgn(i).ToolTipText = "调整工时的起始时间" & i & ",格式为(08:06)"
txtAdjustHours(i).ToolTipText = "调整工时" & i & ",例如当天有吃饭等须自动扣除的时间,如(-1.5)小时"
txtAdjEnd(i).ToolTipText = "调整工时的结束时间" & i & ",格式为(08:06),此处仅显示但不能修改,结果根据<调整工时的起始时间>与<调整工时>计算得到"
chkSpeCard(i).DataField = "W666" & 5 + i
Next i
txtCode.DataField = "W6681"
txtCode.ToolTipText = "排班代码为3位且以A-E的字母开头,如" & Chr(34) & "D05" & Chr(34) & ",双击鼠标显示未使用的排班代码"
chkAddLast.DataField = "C6629"
chkAddLast.ToolTipText = "加班时下班卡是否以最后一次为准"
lblColor.ToolTipText = "定义手工排班时的班次"
For i = 1 To 2 * CLASS_SEC
txtWorkTime(i).DataField = "C662" & i
txtWorkTime(i).ToolTipText = "规定的标准打卡时间,格式为(08:06)"
txtCardRange1(i).DataField = "C668" & i
txtCardRange1(i).ToolTipText = "有效的前打卡时间范围,单位小时.可采用小数(1.5)"
txtCardRange2(i).DataField = "C660" & i
txtCardRange2(i).ToolTipText = "有效的后打卡时间范围,单位小时.可采用小数(1.5)"
chkIsOver(i).DataField = "C669" & i
chkIsOver(i).ToolTipText = "如果该班次跨天请选择本选项"
If i < 5 Then
chkIsAdd(i).DataField = "W669" & i
chkIsAdd(i).ToolTipText = "如果本班次时段不计迟到旷工请选择本选项"
End If
Next i
cobHourKindID.ToolTipText = "建议选择3"
End Sub
Private Sub LoLoadCtrl()
Dim i As Integer
For i = 2 To 4
Load Shape2(i)
Shape2(i).Visible = True
Shape2(i).Move 210, 1455 + (i - 1) * 965
Shape2(i).ZOrder
Load chkIsAdd(i)
chkIsAdd(i).Visible = True
chkIsAdd(i).Move chkIsAdd(i - 1).Left, chkIsAdd(i - 1).Top + 965
Load txtAdjBgn(i)
txtAdjBgn(i).Visible = True
txtAdjBgn(i).Appearance = 0
txtAdjBgn(i).BackColor = &HE0E0E0
txtAdjBgn(i).Move txtAdjBgn(i - 1).Left, txtAdjBgn(i - 1).Top + 965
Load txtAdjEnd(i)
txtAdjEnd(i).Visible = True
txtAdjEnd(i).Move txtAdjEnd(i - 1).Left, txtAdjEnd(i - 1).Top + 965
Load txtAdjustHours(i)
txtAdjustHours(i).Visible = True
txtAdjustHours(i).Move txtAdjustHours(i - 1).Left, txtAdjustHours(i - 1).Top + 965
Load chkSpeCard(i)
chkSpeCard(i).Move chkSpeCard(i - 1).Left, chkSpeCard(i - 1).Top + 965
Next i
For i = 2 To 8
Load lblCaption(i)
If i Mod 2 = 0 Then lblCaption(i).Caption = "下班"
lblCaption(i).Visible = True
lblCaption(i).Move lblCaption(i - 1).Left, lblCaption(i - 1).Top + IIf(i Mod 2 = 0, 400, 565)
lblCaption(i).ZOrder
Load txtWorkTime(i)
txtWorkTime(i).Visible = True
txtWorkTime(i).Move txtWorkTime(i - 1).Left, txtWorkTime(i - 1).Top + IIf(i Mod 2 = 0, 400, 565)
Load txtCardRange1(i)
txtCardRange1(i).Visible = True
txtCardRange1(i).Move txtCardRange1(i - 1).Left, txtCardRange1(i - 1).Top + IIf(i Mod 2 = 0, 400, 565)
Load txtCardRange2(i)
txtCardRange2(i).Visible = True
txtCardRange2(i).Move txtCardRange2(i - 1).Left, txtCardRange2(i - 1).Top + IIf(i Mod 2 = 0, 400, 565)
Load chkIsOver(i)
chkIsOver(i).Visible = True
chkIsOver(i).Move chkIsOver(i - 1).Left, chkIsOver(i - 1).Top + IIf(i Mod 2 = 0, 400, 565)
Next i
Line1(0).ZOrder
For i = 1 To CLASS_SEC
Load Line1(i)
Line1(i).Visible = True
Line1(i).ZOrder
Next i
Line1(1).X1 = 2755
Line1(1).X2 = Line1(1).X1
Line1(2).X1 = 3270
Line1(2).X2 = Line1(2).X1
Line1(3).X1 = 3765
Line1(3).X2 = Line1(3).X1
Line1(4).Visible = False
Line1(4).X1 = 2385
Line1(4).X2 = Line1(4).X1
End Sub
Private Sub Form_Load()
On Error GoTo ErrMessage
Dim i As Integer
Dim lColor As Long
Dim sSQL As String
Dim sSQLList As String
Dim sPlan As String
mbIsBusy = True
mbFirstRun = True
LoSetButtonTag
SetIcon Me
Me.Caption = "班次设置"
lColor = &HFFFFC0
' 置鼠标忙标志
Screen.MousePointer = vbHourglass
txtCode.Locked = True
LoLoadCtrl
For i = 0 To 3
Shape2(i + 1).BackColor = lColor
chkIsOver(i * 2 + 1).BackColor = lColor
chkIsOver(i * 2 + 2).BackColor = lColor
chkIsAdd(i + 1).BackColor = lColor
Next i
If (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
gDBRecordConn.Execute gclsCommon.CBNCSql("DELETE * FROM T6651S001 WHERE E6699 IS NULL")
sSQL = " (W0090 <> 'WC') "
gclsCommon.CBNFillCodeTree TreeList, "WC", "T6651S001", "W6681", , , "C6672", "E6699"
Else
'gTOperRight.ClassRange-班次可设置的权限
'gTOperRight.WorktimeRight-班次可使用的权限
'sSQLList-综合gTOperRight.ClassRange和gTOperRight.WorktimeRight后的权限
sSQLList = LoAddClassRight(gTOperRight.ClassRange, gTOperRight.WorktimeRight)
sSQL = gclsCommon.CBNGetCondiSQL(sSQLList, "W6681")
gclsCommon.CBNFillCodeTree TreeList, "WC", "T6651S001", "W6681", , , "C6672", "E6699", , sSQL & " OR (W0090 = 'WC') "
End If
Set madoWkTmRS = New ADODB.Recordset
mbDisabled1 = True
sSQLList = ""
For i = 1 To 2 * CLASS_SEC
sSQLList = sSQLList & "C660" & i & "," & "C668" & i & ","
Next i
sSQL = "SELECT " & sSQLList & "ID,C6611,C6612,C6613,C6614,C6621,C6622,C6623,C6624,C6625,C6626," & _
"C6627,C6628,C6629,C6672,C6673,C6674,C6676,C6677,C6678,C6679,C6680,C6689,C6691,C6692,C6693,C6694,C6695," & _
"C6696,C6697,C6698,E6699,W6666,W6667,W6668,W6669,W6680,W6681,W6691,W6692,W6693,W6694,W0093,W0090,W0091 " & _
"FROM T6651S001 WHERE (W0090<>'WC') " & IIf(sSQL = "", "", " AND " & sSQL) & " ORDER BY E6699"
madoWkTmRS.Open sSQL, gDBRecordConn, adOpenStatic, adLockOptimistic
mbDisabled1 = False
mbEditFlag = False
mbAddNewFlag = False
LoSetButtons True
LoSetDataField
mbIsBusy = False
Dim adoTempRS As ADODB.Recordset
Set adoTempRS = New ADODB.Recordset
adoTempRS.Open "SELECT * FROM T6652S001 ORDER BY C6689", gDBRecordConn, adOpenStatic, adLockReadOnly
With adoTempRS
Do While Not adoTempRS.EOF
cobHourKindID.AddItem !C6689 & SPLIT_SYMBOL & !W6684
cobHourKindID.ItemData(cobHourKindID.NewIndex) = !C6689
.MoveNext
Loop
.Close
End With
mbFirstRun = False
TreeView1.LineStyle = tvwRootLines
TreeView1.LabelEdit = tvwManual
TreeView1.Indentation = 50
TreeView1.ImageList = gclsCommon.CBNGetImageList
TreeView1.Style = tvwTreelinesPlusMinusPictureText
LoFillValidClassID
Screen.MousePointer = vbDefault
Exit Sub
ErrMessage:
LoShowMsg Err.Description
Resume Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
If mbAddNewFlag Then
cmdCancel_Click
End If
Set madoWkTmRS = Nothing
If mbDataChanged Then
Erase gTClassDef
End If
Screen.MousePointer = vbDefault
End Sub
Private Sub cmdAdd_Click()
On Error GoTo AddErr
mbAddNewFlag = True
mbEditFlag = False
If madoWkTmRS.RecordCount > 0 Then
If Not madoWkTmRS.EOF Then
mvBookMark = madoWkTmRS.Bookmark
End If
End If
LoSetButtons False
LoShowValue False
gclsInclude.MySetTxtSelect txtWorkTime(1)
Exit Sub
AddErr:
LoShowMsg Err.Description
End Sub
Private Sub cmdEdit_Click()
On Error GoTo EditErr
If madoWkTmRS.RecordCount = 0 Then Exit Sub
mbEditFlag = True
mbAddNewFlag = False
LoSetButtons False
msCode = txtCode
msClassID = txtClass
If Not madoWkTmRS.EOF Then
mvBookMark = madoWkTmRS.Bookmark
End If
Exit Sub
EditErr:
LoShowMsg Err.Description
End Sub
Private Sub cmdCancel_Click()
On Error GoTo errorCancel
LoSetButtons True
mbEditFlag = False
mbAddNewFlag = False
If madoWkTmRS.RecordCount > 0 Then
madoWkTmRS.Bookmark = mvBookMark
End If
TreeList.SetFocus
Exit Sub
errorCancel:
LoShowMsg Err.Description
End Sub
Private Sub cmdDelete_Click()
On Error GoTo DeleteErr
Dim sKey As String
If madoWkTmRS.RecordCount = 0 Then Exit Sub
With madoWkTmRS
sKey = !W6681 & "_"
If MsgBox("确信删除编号为:" & !W6681 & " 的班次吗?", vbOKCancel + vbQuestion) = vbCancel Then Exit Sub
ModifyRight "W1135", !W6681, ACT_DEC
If txtClass <> "" Then gclsCommon.CBNSaveEvents OET_DEL_CLASS, txtClass
.Delete
TreeList.Nodes.Remove sKey
If .RecordCount = 0 Then LoShowValue False: Exit Sub
.MoveNext
If .EOF Then .MoveLast
End With
Exit Sub
DeleteErr:
LoShowMsg Err.Description
Screen.MousePointer = vbDefault
End Sub
Private Sub cmdSave_Click()
Dim i As Long
Dim bChange As Boolean
Dim bFlag As Boolean
Dim sMsg As String
Dim sinTemp As Single
Dim DDate As Date
On Error GoTo UpdateErr
If Len(txtDesc) = 0 Then
LoShowMsg "班次描述不能为空!"
gclsInclude.MySetTxtSelect txtDesc
Exit Sub
End If
If Len(txtClass) = 0 Then
LoShowMsg "班次代码不能为空!"
gclsInclude.MySetTxtSelect txtClass
Exit Sub
End If
If gclsCommon.CBNIsReservePlan(txtClass) Then
LoShowMsg txtClass & "班次代码为系统保留代码,请重新填写!"
gclsInclude.MySetTxtSelect txtClass
txtClass = msClassID
Exit Sub
End If
If Len(txtCode) = 0 Then
MsgBox "排班代码不能为空,请重新填写!", vbCritical
TreeView1.Visible = True
TreeView1.SetFocus
Exit Sub
End If
'检查打卡的时间是否正确
mbDataChanged = True
For i = 1 To 2 * CLASS_SEC
If Len(txtWorkTime(i)) = 0 Then
txtCardRange1(i) = 0
txtCardRange2(i) = 0
txtWorkTime(i) = "00:00:00"
ElseIf Not gclsCommon.CBNIsTimeRight(txtWorkTime(i)) Then
LoShowMsg "输入的有效打卡时间数据不合法,请检查!"
' gclsInclude.MySetTxtSelect txtWorkTime(i)
Exit Sub
End If
If (i > 1) And (i Mod 2 = 0) Then
bFlag = False
If txtWorkTime(i - 1) = "00:00:00" And txtWorkTime(i) <> "00:00:00" Then
gclsInclude.MySetTxtSelect txtWorkTime(i - 1)
bFlag = True
ElseIf txtWorkTime(i - 1) <> "00:00:00" And txtWorkTime(i) = "00:00:00" Then
gclsInclude.MySetTxtSelect txtWorkTime(i)
bFlag = True
End If
If bFlag Then
LoShowMsg "输入的有效打卡时间不完整,请检查!"
Exit Sub
End If
If txtWorkTime(i - 1) <> "00:00:00" Then
If CDate(txtWorkTime(i - 1)) >= CDate(txtWorkTime(i)) Then
If chkIsOver(i) = 0 Then
LoShowMsg "输入的下班打卡时间应该大于上班时间,请检查!"
gclsInclude.MySetTxtSelect txtWorkTime(i)
Exit Sub
End If
End If
End If
Else
If txtWorkTime(1) = "00:00:00" Then
LoShowMsg "输入的第一个班次的上班时间错误,请检查!"
gclsInclude.MySetTxtSelect txtWorkTime(1)
Exit Sub
End If
End If
Next i
For i = 1 To 2 * CLASS_SEC
If Len(txtCardRange1(i)) = 0 Then txtCardRange1(i) = 0
If Len(txtCardRange2(i)) = 0 Then txtCardRange2(i) = 0
If txtWorkTime(i) <> "00:00:00" Then
If Not IsNumeric(txtCardRange1(i)) Or txtCardRange1(i) = 0 Then
LoShowMsg "输入的有效打卡前取值范围数据不合法,请检查!"
gclsInclude.MySetTxtSelect txtCardRange1(i)
Exit Sub
End If
If Not gTAttendCtl.Use1CardRange Then
If Not IsNumeric(txtCardRange2(i)) Or txtCardRange2(i) = 0 Then
LoShowMsg "输入的有效打卡后取值范围数据不合法,请检查!"
gclsInclude.MySetTxtSelect txtCardRange2(i)
Exit Sub
End If
End If
End If
Next i
For i = 1 To CLASS_SEC
sinTemp = Val(txtAdjustHours(i).Text)
If sinTemp <> 0 Then
If Len(txtAdjBgn(i)) = 0 Then
txtAdjBgn(i) = "00:00:00"
ElseIf Not gclsCommon.CBNIsTimeRight(txtAdjBgn(i)) Then
LoShowMsg "输入的调整工时起始时间数据不合法,请检查!"
Exit Sub
ElseIf CDate(txtAdjBgn(i)) = 0 Then
If sinTemp < 0 Then
LoShowMsg "因为调整工时为" & sinTemp & "小时,所以必须正确输入的调整工时起始时间,请检查!"
gclsInclude.MySetTxtSelect txtAdjBgn(i)
Exit Sub
End If
Else
bFlag = False
If CDate(txtAdjBgn(i)) > CDate(txtWorkTime(i * 2).Text) Then
If chkIsOver(i * 2) <> 1 Then
bFlag = True
LoShowMsg "第" & i & "段的调整工时起始时间超出该段的班次结束时间,请检查!"
End If
ElseIf CDate(txtAdjBgn(i)) < CDate(txtWorkTime(i * 2 - 1).Text) Then
bFlag = True
LoShowMsg "第" & i & "段的调整工时起始时间小于该段的班次起始时间,请检查!"
Else
DDate = DateAdd("n", Abs(sinTemp * 60), CDate(txtAdjBgn(i)))
txtAdjEnd(i) = DDate
If DDate > CDate(txtWorkTime(i * 2).Text) Then
bFlag = True
LoShowMsg "第" & i & "段的调整工时结束时间超出该段的班次结束时间,请做相应的修改!"
End If
End If
If bFlag Then
gclsInclude.MySetTxtSelect txtAdjBgn(i)
Exit Sub
End If
End If
End If
Next i
If mbAddNewFlag Then
If gclsDBFunc.dbIsExist("T6651S001", "E6699", txtClass, eadChar, , gDBRecordConn) Then
LoShowMsg "班次代号不能重复!"
gclsInclude.MySetTxtSelect txtClass
Exit Sub
End If
mlID = gclsCommon.CBNGetMaxID("T6651S001"): mlID = mlID + 1
mbDisabled1 = True
madoWkTmRS.AddNew
mbDisabled1 = False
gclsCommon.CBNSaveEvents OET_ADD_CLASS, txtClass
ElseIf mbEditFlag Then
If msClassID <> txtClass Then
If gclsDBFunc.dbIsExist("T6651S001", "E6699", txtClass, eadChar, , gDBRecordConn) Then
MsgBox "班次代号不能重复!"
txtClass = msClassID
gclsInclude.MySetTxtSelect txtClass
Exit Sub
End If
bChange = True
End If
mlID = madoWkTmRS!ID
gclsCommon.CBNSaveEvents OET_MDF_CLASS, txtClass
End If
If CLng(txtClassTime) < CLng(txtHours) Then
If MsgBox("正班段的工时(" & CLng(txtClassTime) & ")小于标准工时(" & CLng(txtHours) & "),是否继续?", vbOKCancel) = vbCancel Then
gclsInclude.MySetTxtSelect txtClassTime
Exit Sub
End If
End If
sMsg = LoSetValue
If sMsg <> "" Then MsgBox sMsg, vbCritical: Exit Sub
If mbEditFlag Then
If msCode <> txtCode Then
TreeList.Nodes.Remove msCode & "_"
Set mNode = TreeList.Nodes.Add(madoWkTmRS!W0090 & "_", tvwChild, madoWkTmRS!W6681 & "_")
Else
Set mNode = TreeList.Nodes(msCode & "_")
End If
ElseIf mbAddNewFlag Then
Set mNode = TreeList.Nodes.Add(madoWkTmRS!W0090 & "_", tvwChild, madoWkTmRS!W6681 & "_")
End If
mNode.Text = madoWkTmRS!W6681 & SPLIT_SYMBOL & "(" & madoWkTmRS!E6699 & ")" & madoWkTmRS!C6672
mNode.Tag = madoWkTmRS!W6681 & "_WC_" & madoWkTmRS!E6699
mNode.Image = "IMG024"
If bChange Then
'将所有的表中的班次代码替换
'涉及到的表有"T6621A001","T6623A001","T6632A001"
If Not gclsCommon.CBNModifyBatch(gDBRecordConn, _
"W6699", _
txtClass, _
msClassID, _
"T6651S001", , , , , _
StatusBar1) Then GoTo EndSub
For i = 1 To CLASS_SEC
gDBRecordConn.Execute "UPDATE T6632A001 SET W660" & i & " = '" & txtClass & "' WHERE W660" & i & " = '" & msClassID & "'"
Next i
gDBRecordConn.Execute "UPDATE T6632A001 SET W6639 = '" & txtClass & "' WHERE W6639 = '" & msClassID & "'"
End If
mNode.Selected = True
mbIsBusy = True
madoWkTmRS.MoveFirst
mbIsBusy = False
' madoWkTmRS.Find
LoSetButtons True
mbEditFlag = False
mbAddNewFlag = False
TreeList.SetFocus
StatusBar1.Panels(1).Text = ""
Exit Sub
UpdateErr:
If Err.Number = 3022 Then
LoShowMsg "班次序号不能重复!"
ElseIf Err = -2147467259 Then
LoShowMsg Err.Description
Else
LoShowMsg "输入的数据不合法或" & Err.Description
Resume Next
End If
EndSub:
LoSetButtons False
Screen.MousePointer = vbDefault
End Sub
Private Sub LoSetButtons(bVal As Boolean)
Dim i As Integer
cmdAdd.Visible = bVal
cmdEdit.Visible = bVal
cmdSearch.Visible = bVal
cmdSave.Visible = Not bVal
cmdCancel.Visible = Not bVal
cmdDelete.Visible = bVal
' cmdClose.Visible = bVal
lblColor.Enabled = Not bVal
txtDesc.Locked = bVal
txtHours.Locked = bVal
txtMustAdd.Locked = bVal
txtHourKindID.Locked = bVal
TreeList.Enabled = bVal
txtClass.Locked = bVal
txtClassTime.Locked = bVal
chkAddLast.Enabled = Not bVal
cobHourKindID.Enabled = Not bVal
For i = 1 To 2 * CLASS_SEC
txtWorkTime(i).Locked = bVal
txtCardRange1(i).Locked = bVal
txtCardRange2(i).Locked = bVal
chkIsOver(i).Enabled = Not bVal
If i < 5 Then
chkIsAdd(i).Enabled = Not bVal
chkSpeCard(i).Enabled = Not bVal
txtAdjustHours(i).Locked = bVal
txtAdjBgn(i).Locked = bVal
End If
Next i
End Sub
Private Sub LoShowMsg(ByVal fsMsg As String)
StatusBar1.Panels(1).Text = fsMsg
MsgBox fsMsg
End Sub
Private Sub Frame1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
If TreeView1.Visible Then TreeView1.Visible = False
End Sub
Private Sub lblColor_Click()
On Error GoTo ErrLabel
frmMain.dlgCommonDialog.CancelError = True
frmMain.dlgCommonDialog.ShowColor
shpColor.BackColor = frmMain.dlgCommonDialog.Color
lblColor.ForeColor = &HFFFFFF - shpColor.BackColor
ErrLabel:
End Sub
Private Sub SSTab1_Click(PreviousTab As Integer)
Dim i As Integer
Dim bVisible As Boolean
'Frame1(4).Visible = False
bVisible = SSTab1.Tab = 0
For i = 1 To 2 * CLASS_SEC
txtCardRange1(i).Visible = bVisible
txtCardRange2(i).Visible = bVisible
chkIsOver(i).Visible = bVisible
If gTAttendCtl.Use1CardRange Then
txtCardRange2(i).Visible = False
End If
Next i
For i = 1 To CLASS_SEC
chkIsAdd(i).Visible = bVisible
txtAdjustHours(i).Visible = bVisible
txtAdjBgn(i).Visible = bVisible
txtAdjEnd(i).Visible = bVisible
chkSpeCard(i).Visible = Not bVisible
Next i
Line1(1).Visible = bVisible
Line1(2).Visible = bVisible
Line1(3).Visible = bVisible
Line1(4).Visible = Not bVisible
lblCpt(3).Visible = bVisible
lblCpt(4).Visible = bVisible
lblCpt(5).Visible = bVisible
lblCpt(2).Caption = IIf(bVisible, "打卡范围", "特卡")
'Frame1(4).Visible = True
End Sub
Private Sub TreeList_NodeClick(ByVal Node As MSComctlLib.Node)
Dim bEnabled As Boolean
Dim sClass As String
On Error GoTo ErrLabel
sClass = gclsCommon.CBNGetFirstData(Node)
If Mid(sClass, 2) = "00" Then
LoShowValue False
Else
madoWkTmRS.Filter = "W6681 = '" & sClass & "'"
If gTAppLicInfo.SysLoginSYS Or gTAppLicInfo.SysLoginSA Then
bEnabled = True
Else
If gclsInclude.MyIsInList(gTOperRight.ClassRange, sClass) Then
bEnabled = True
End If
End If
End If
' cmdAdd.Enabled = bEnabled
cmdEdit.Enabled = bEnabled
' cmdSave.Enabled = bEnabled
' cmdCancel.Enabled = bEnabled
cmdDelete.Enabled = bEnabled
Exit Sub
ErrLabel:
MsgBox Error
End Sub
Private Sub TreeView1_LostFocus()
If TreeView1.Visible Then TreeView1.Visible = False
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
Dim sDesc As String
If Node.Tag = "CLASS" Then
TreeView1.Visible = False
sDesc = Left(Node.Key, Len(Node.Key) - 1)
txtCode.Text = sDesc
If txtClass.Text = "" Then txtClass.Text = sDesc
If txtDesc.Text = "" Then
sDesc = sDesc & "班"
If IsDate(txtWorkTime(1)) Then
If CDate(txtWorkTime(1)) <> 0 Then
sDesc = sDesc & " (" & txtWorkTime(1) & ")"
End If
End If
txtDesc.Text = sDesc
End If
End If
End Sub
Private Sub txtAdjBgn_KeyPress(Index As Integer, KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789:", True, True)
End Sub
Private Sub txtClass_KeyPress(KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "_", False, False)
End Sub
Private Sub txtCode_DblClick()
Dim sKey As String
If mbAddNewFlag Or mbEditFlag Then
LoFillValidClassID
sKey = txtCode.Text
If sKey <> "" Then
sKey = Left(sKey, 1) & "_"
If gclsCommon.CBNIsNodeExist(TreeView1.Nodes, sKey) Then
TreeView1.Nodes(sKey).Selected = True
TreeView1.Nodes(sKey).Expanded = True
End If
End If
TreeView1.Visible = True
TreeView1.SetFocus
End If
End Sub
Private Sub txtWorkTime_KeyPress(Index As Integer, KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789:", True, True)
End Sub
Private Sub txtCardRange1_KeyPress(Index As Integer, KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789.", True, True)
End Sub
Private Sub txtCardRange2_KeyPress(Index As Integer, KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789.", True, True)
End Sub
Private Sub txtHourKindID_KeyPress(KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789", True, True)
End Sub
Private Sub txtHours_KeyPress(KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789.", True, True)
End Sub
Private Sub txtMustAdd_KeyPress(KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789.", True, True)
End Sub
Private Sub txtAdjustHours_KeyPress(Index As Integer, KeyAscii As Integer)
KeyAscii = gclsInclude.MyValiText(KeyAscii, "0123456789-.", True, True)
End Sub
Private Sub LoFillValidClassID()
Dim adoTempRS As ADODB.Recordset
Dim bFlag As Boolean
Dim oNode As MSComctlLib.Node
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim sPlanCode As String
Set adoTempRS = New ADODB.Recordset
Dim sCode() As String
adoTempRS.Open "SELECT W6681 FROM T6651S001 WHERE (W0090<>'WC') ORDER BY W6681", gDBRecordConn, adOpenStatic, adLockReadOnly
TreeView1.Nodes.Clear
Set oNode = TreeView1.Nodes.Add(, , 0 & "_", "未使用的排班代码", "IMG072")
oNode.ExpandedImage = "IMG071"
oNode.Expanded = True
If adoTempRS.RecordCount > 0 Then
ReDim sCode(1 To adoTempRS.RecordCount)
For i = 1 To adoTempRS.RecordCount
sCode(i) = UCase(adoTempRS!W6681)
adoTempRS.MoveNext
Next i
Else
ReDim sCode(0)
End If
For i = LBound(gsValidClass) To UBound(gsValidClass)
If (gsValidClass(i) <> "Z") Or (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
Set oNode = TreeView1.Nodes.Add("0_", tvwChild, gsValidClass(i) & "_", gsValidClass(i) & "班代码", "IMG054")
End If
Next i
If (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
For i = LBound(gsValidClass) To UBound(gsValidClass)
For j = 1 To 99
bFlag = False
sPlanCode = gsValidClass(i) & Format(j, "00")
For k = 1 To UBound(sCode)
If sCode(k) = sPlanCode Then
bFlag = True
Exit For
End If
Next k
If Not bFlag Then
Set oNode = TreeView1.Nodes.Add(gsValidClass(i) & "_", tvwChild, sPlanCode & "_", sPlanCode & "班", "IMG030")
oNode.Tag = "CLASS"
End If
Next j
Next i
Else
Dim sSplit
sSplit = Split(gTOperRight.ClassRange, ",")
'sSplit-班次可设置的权限
'sCode-班次可使用的权限
For i = LBound(sSplit) To UBound(sSplit)
bFlag = False
For k = 1 To UBound(sCode)
If sCode(k) = sSplit(i) Then
bFlag = True
Exit For
End If
Next k
If Not bFlag Then
Set oNode = TreeView1.Nodes.Add(Left(sSplit(i), 1) & "_", tvwChild, sSplit(i) & "_", sSplit(i) & "班", "IMG030")
oNode.Tag = "CLASS"
End If
Next i
End If
End Sub
Private Function LoAddClassRight(fsRight1 As String, fsRight2 As String) As String
'fsRight1-班次可设置的权限
'fsRight2-班次可使用的权限
'综合权限的意义为：只要fsRight1有的必须有，但如果fsRight1中没有而fsRight2有，则要加上
Dim l As Long
Dim sCombo As String
Dim sSplit1
sCombo = fsRight1 & "," & fsRight2
sSplit1 = Split(sCombo, ",")
gclsInclude.MyRemoveDupes sSplit1
gclsInclude.MyRemoveBlank sSplit1
gclsInclude.MyQuickSort sSplit1, 0, UBound(sSplit1)
For l = LBound(sSplit1) To UBound(sSplit1)
LoAddClassRight = LoAddClassRight & sSplit1(l) & ","
Next l
LoAddClassRight = Left(LoAddClassRight, Len(LoAddClassRight) - 1)
End Function
Private Sub LoSetButtonTag()
cmdAdd.Tag = "IMG048"
cmdDelete.Tag = "IMG021"
cmdEdit.Tag = "IMG025"
cmdCancel.Tag = "IMG014"
cmdExit.Tag = "IMG029"
cmdSave.Tag = "IMG041"
cmdSearch.Tag = "IMG031"
End Sub