frm_rpt_holiday.frm

考勤系统,智能判断刷卡异常,是一大型ERP系统的一个分支

            EndProperty
         EndProperty
      End
      Begin VB.PictureBox Picture2 
         Height          =   0
         Left            =   0
         ScaleHeight     =   0
         ScaleWidth      =   0
         TabIndex        =   7
         Top             =   0
         Width           =   0
      End
   End
   Begin VB.Label Label2 
      Caption         =   "开始日期："
      ForeColor       =   &H00C00000&
      Height          =   180
      Index           =   0
      Left            =   3360
      TabIndex        =   5
      Top             =   405
      Width           =   975
   End
   Begin VB.Label Label2 
      Caption         =   "截止日期："
      ForeColor       =   &H00C00000&
      Height          =   180
      Index           =   1
      Left            =   6360
      TabIndex        =   4
      Top             =   420
      Width           =   975
   End
End
Attribute VB_Name = "frm_Rpt_holiday"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit


Dim strSQL As String
Dim strSQL2 As String
Dim strSQL3 As String
Dim strSQL4 As String

Private adoprimaryRS   As ADODB.Recordset
Private adoPrimaryRS2  As ADODB.Recordset
Private adoPrimaryRS3  As ADODB.Recordset
Private adoprimaryRS4  As ADODB.Recordset

Dim mDB As mDB





Private Sub datagrid1_HeadClick(ByVal intColIndex As Integer)
    '   'Sort by clicked column
    '   With adoprimaryRS
    '     .Sort = .Fields(ColIndex).Name & " ASC"
    '   End With
    '   DataGrid1.Refresh
    Static px As Integer
    px = px + 1
    'Sort by clicked column
    With adoprimaryRS
        If px Mod 2 = 0 Then
            .Sort = .Fields(intColIndex).Name & " ASC"
        Else
            .Sort = .Fields(intColIndex).Name & " DESC"
        End If
    
    End With
    DataGrid1.Refresh



End Sub

Private Sub DataGrid1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub

Private Sub Reload_Datalist()
'    'Dim DmDB As New mDB
'    'DmDB.InitDB_SQL "Zjxy", "xinya", "reformer", "5148936"
'    strSQL = "select * from E_TblCL"
'    Set adoprimaryRS = DmDB.adoprimaryRS(strSQL)
'    Debug.Print adoprimaryRS.RecordCount
'    With DataList1
'        Set .RowSource = adoprimaryRS
'        .BoundColumn = "tblID"
'        .ListField = "tblMC"
'        .ReFill
'    End With
'    'Set DmDB = Nothing

End Sub
'''''''''''''=======================================================================

Private Sub DataGrid1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim Index As Integer
    Dim yRow As Integer
    Dim sTmp
    On Error Resume Next

    Index = DataGrid1.ColContaining(X)
    yRow = DataGrid1.RowContaining(Y)


    If Button = vbRightButton Then
        Dim ltmp As Long
        'ltmp = oMenu.PopUp("过滤", "=过滤", "like过滤条件", "3列过滤", "2列过滤")
        'ltmp = oMenu.Popup("过滤", "like过滤条件", "2列过滤", "3列过滤", ">", "<", "-", "收发明细（按订单）")
        ltmp = oMenu.Popup("like过滤条件", "删除记录")
        Dim Scode As String
        Dim iTmp As Single


        Select Case ltmp
            Case 1

                'adoPrimaryRS4.Filter = DataGrid1.Columns(Index).Caption & "='" & DataGrid1.Columns(Index).Text & "'"
                '
                'Case 2
                '''''''''''''==================
                sTmp = InputBox("请输入过滤条件。", "NewAsia")
                If Len(sTmp) Then
                    adoprimaryRS.Filter = DataGrid1.Columns(Index).Caption & " like '" & sTmp & "%'"
                End If

                'ElseIf ltmp = 4 Then
                '
                'adoPrimaryRS2.Filter = DataGrid1.Columns(index - 1).Caption & "='" & DataGrid1.Columns(index - 1).Text & "' and " & DataGrid1.Columns(index).Caption & "='" & DataGrid1.Columns(index).Text & "' and " & DataGrid1.Columns(index + 1).Caption & "='" & DataGrid1.Columns(index + 1).Text & "'"
                '
                'ElseIf ltmp = 5 Then
                '
                'adoPrimaryRS2.Filter = DataGrid1.Columns(index).Caption & "='" & DataGrid1.Columns(index).Text & "' and " & DataGrid1.Columns(index + 1).Caption & "='" & DataGrid1.Columns(index + 1).Text & "'"
            Case 2
                If MsgBox("确实要删除此条记录吗？(" & DataGrid1.Columns(1).Text & ")", vbYesNo, "提示：") = vbYes Then
    Select Case List1.ListIndex + 1
        Case 1
        strSQL = "Delete from holidayreg where ID=" & DataGrid1.Columns(0).Text
        mDB.ExecuteSQL strSQL
        
        Case 2
        strSQL = "Delete from evectionreg where ID=" & DataGrid1.Columns(0).Text
        mDB.ExecuteSQL strSQL
    End Select
                List1_Click
                
                End If
            Case 3
                adoprimaryRS.Filter = DataGrid1.Columns(Index).Caption & "='" & DataGrid1.Columns(Index).Text & "' and " & DataGrid1.Columns(Index + 1).Caption & "='" & DataGrid1.Columns(Index + 1).Text & "'"

            Case 4

                adoprimaryRS.Filter = DataGrid1.Columns(Index - 1).Caption & "='" & DataGrid1.Columns(Index - 1).Text & "' and " & DataGrid1.Columns(Index).Caption & "='" & DataGrid1.Columns(Index).Text & "' and " & DataGrid1.Columns(Index + 1).Caption & "='" & DataGrid1.Columns(Index + 1).Text & "'"

            Case 5
                'Dim iTmp As Integer
                iTmp = InputBox("请输入过滤的数字：", "范围过滤：", 0, X, Y)

                adoprimaryRS.Filter = DataGrid1.Columns(Index).Caption & ">=" & iTmp     ''''  sMan & "' or " & DataGrid1.Columns(4).Caption & "= '" & sMan & "'"
            Case 6
                iTmp = InputBox("请输入过滤的数字：", "范围过滤：", 0, X, Y)

                adoprimaryRS.Filter = DataGrid1.Columns(Index).Caption & "<" & iTmp     ''''  sMan & "' or " & DataGrid1.Columns(4).Caption & "= '" & sMan & "'"
            Case 8
                'DataCombo1.Text = DataGrid1.Columns(0).Text
                'Command1_Click 0
                'DataCombo1.Text = ""

        End Select

        'If ltmp > 0 And ltmp < 7 Then
        'Text1(4).Text = Sum_RsFld(adoPrimaryRS4, "收")
        'Text1(5).Text = Sum_RsFld(adoPrimaryRS4, "过程余量")
        'End If

    End If
End Sub

Private Sub List1_Click()
    'On Error Resume Next

    Select Case List1.ListIndex + 1
        Case 1
'            strSQL = "select a.ID as 序号,a.emplyid as 工号,emplyname as 姓名,holidaydecs as 请假类型,bgndatetime as 开始时间,enddatetime as 结束时间,hours as 请假工时,ratifier as 批准人,makeid as 登记,makedate as 制单时间,(case when isday<>0 then '整天' else '' end) as 是否整天,bzsm as 备注 from holidayreg a,emply b,holidaykind c where a.emplyid=b.emplyid and a.holidayid=c.holidayid and makedate >='" & DTPicker1(0).Value & "' and bgndatetime<'" & DTPicker1(1).Value + 1 & "'"
'            strSQL = "select a.ID as 序号,a.emplyid as 工号,emplyname as 姓名,holidaydecs as 请假类型,bgndatetime as 开始时间,enddatetime as 结束时间,hours as 请假工时,ratifier as 批准人,makeid as 登记,(case when isday<>0 then '整天' else '' end) as 是否整天,bzsm as 备注 from holidayreg a,emply b,holidaykind c where a.emplyid=b.emplyid and a.holidayid=c.holidayid and bgndatetime >='" & DTPicker1(0).Value & "' and bgndatetime<'" & DTPicker1(1).Value + 1 & "'"
            strSQL = "select a.ID as 序号,a.emplyid as 工号,emplyname as 姓名,dptname as 所属部门,holidaydecs as 请假类型,bgndatetime as 开始时间,enddatetime as 结束时间,hours as 请假工时,ratifier as 批准人,makeid as 登记,(case when isday<>0 then '整天' else '' end) as 是否整天,bzsm as 备注 from holidayreg a,emply b,holidaykind c,depart d where b.dptid=d.dptid and a.emplyid=b.emplyid and a.holidayid=c.holidayid and bgndatetime >='" & DTPicker1(0).Value & "' and bgndatetime<'" & DTPicker1(1).Value + 1 & "'"
        Case 2
'            strSQL = "select a.ID as 序号, a.emplyid as 工号,emplyname as 姓名,evectiondecs as 出差类型,bgndatetime as 开始时间,enddatetime as 结束时间,hours as 出差工时,ratifier as 批准人,makeid as 登记,makedate as 制单时间,(case when isday<>0 then '整天' else '' end) as 是否整天,bzsm as 备注 from evectionreg a,emply b,evectionkind c where a.emplyid=b.emplyid and a.evectionid=c.evectionid and bgndatetime >='" & DTPicker1(0).Value & "' and bgndatetime <'" & DTPicker1(1).Value + 1 & "'"
            strSQL = "select a.ID as 序号, a.emplyid as 工号,emplyname as 姓名,dptname as 所属部门,evectiondecs as 出差类型,bgndatetime as 开始时间,enddatetime as 结束时间,hours as 出差工时,ratifier as 批准人,makeid as 登记,(case when isday<>0 then '整天' else '' end) as 是否整天,bzsm as 备注 from evectionreg a,emply b,evectionkind c,depart d where b.dptid=d.dptid and a.emplyid=b.emplyid and a.evectionid=c.evectionid and bgndatetime >='" & DTPicker1(0).Value & "' and bgndatetime <'" & DTPicker1(1).Value + 1 & "'"

    End Select
'Debug.Print strSQL

    Set adoprimaryRS = mDB.adoprimaryRS(strSQL)
    With DataGrid1
        .ClearFields
        Set .DataSource = adoprimaryRS
'            .Columns(0).width = 0
'            .Columns(1).width = 0
'            .Columns(2).width = 0
'            .Columns(3).width = 2000
            
            .AllowAddNew = False
            .AllowDelete = False
        .Refresh
    End With

End Sub

Private Sub Form_Load()
    Set mDB = New mDB
    Debug.Print SQLConnDR
    
    mDB.InitDB_RY SQLConnDR

   
    With List1
        .AddItem "员工请假信息统计"
        .AddItem "员工出差信息统计"
'        .AddItem "费用类型"
'        .AddItem "用车部门维护"
'        .AddItem "移动电话EMAIL登记"
'        .AddItem "档案类别表"
'        .AddItem "档案来源表"
'        .AddItem "存放地点表"
        .Refresh
    End With
    
    Me.Move 0, 0, width00 - 80, height00 - 80
    DTPicker1(0).Value = DateSerial(Year(Date), Month(Date), 1)
    DTPicker1(1).Value = Date


End Sub


Private Sub Form_Resize()
    On Error Resume Next
    With Me
        List1.Move 120, 700, 3000, .ScaleHeight - 840
        DataGrid1.Move 3100, 700, Me.width - 3500, ScaleHeight - 840
    End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'DataList1.SetFocus
    mDB.KillDB
    Set mDB = Nothing

End Sub



    ''''=======================================================


Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error GoTo Err1

Select Case Button.Index
Case 1

ToExcel.ToExcel adoprimaryRS
'ToExcel.ToExcel_noFld adoprimaryRS, "A1"

'ToExcel.ToExcelFlds adoprimaryRS, "部门名称,经理工号,经理,邮箱,电话,地址"

Case 2
Unload Me


End Select

Exit Sub
Err1:
' MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source & vbCrLf & Err.LastDllError & vbCrLf & Err.HelpContext, vbInformation, App.Title & "  -  Advisory"
DisPlayErr Err


End Sub