📄 frm_rpt_kaoqinrpt.frm
字号:
'' .Columns(3).width = 0
' .Columns(3).Caption = "工号"
' .Columns(4).Caption = "姓名"
' .Columns(5).Caption = "评分"
' .Columns(6).Caption = "工作天数"
.Refresh
End With
Case 6
Screen.MousePointer = 11
ExportSalary
Screen.MousePointer = 0
Case 7
Unload Me
End Select
Exit Sub
Err1:
MsgBox Err.Number & "," & Err.Description
End Sub
Private Sub ExportSalary()
strSQL = "TRUNCATE TABLE wkrslt2"
mDB.ExecuteSQL strSQL
strSQL = "insert into wkrslt2(dptname,emplyid,emplyname,正常天,异常天,休息天,休日加班天,出差天,请假天,迟到次,迟到分,早退次,早退分,实际工时,标准工时,在岗工时,平时加班,休日加班,请假工时) select dptname as 部门,emplyid as 工号,emplyname as 姓名,sum(case when wktmrslt_flag=7 then 1 else 0 end) as 正常天,sum(case when wktmrslt_flag=1 then 1 else 0 end) as 异常天," & _
"sum(case when wktmrslt_flag=4 or wktmrslt_flag=5 then 1 else 0 end) as 休息天,sum(case when wktmrslt_flag=9 then 1 else 0 end) as 休日加班天,sum(case when wktmrslt_flag=3 then 1 else 0 end) as 出差天,sum(case when wktmrslt_flag=2 then 1 else 0 end) as 请假天," & _
"sum(case when latertime1+latertime2>0 then 1 else 0 end) as 迟到次,sum(latertime1+latertime2) as 迟到分,sum(case when earlytime1+earlytime2>0 then 1 else 0 end) as 早退次,sum(earlytime1+earlytime2) as 早退分," & _
"sum(datwktm) as 实际工时,sum(standwktm) as 标准工时,sum(workwktm) as 在岗工时,sum(overwktm) as 平时加班工时,sum(sunwktm) as 休日加班工时,sum(holidaysum) as 请假工时 from wktmrslt where caldate between '" & DTPicker1(0).Value & "' and '" & DTPicker1(1).Value & "' group by dptname,emplyid,emplyname"
mDB.ExecuteSQL strSQL
' iniFunc.writeINI App.Path & "\abcd.ini", "a", "b", strSQL
strSQL = "select * from emply" '''' where bx_yl is not null or bx_yw is not null"
Set adoprimaryRS = mDB.adoprimaryRS(strSQL)
strSQL2 = "select * from wkrslt2"
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
With adoPrimaryRS2
.MoveFirst
Do While Not .EOF
On Error Resume Next
adoprimaryRS.Find "emplyid='" & .Fields("emplyid").Value & "'", 0, adSearchForward, adBookmarkFirst
If Not adoprimaryRS.EOF Then
.Fields("常规工资").Value = IIf(Len(adoprimaryRS.Fields("gzjs").Value) = 0, 0, adoprimaryRS.Fields("gzjs").Value)
.Fields("jjjs").Value = IIf(Len(adoprimaryRS.Fields("jjjs").Value) = 0, 0, adoprimaryRS.Fields("jjjs").Value)
.Fields("保险1").Value = IIf(Len(adoprimaryRS.Fields("bx_yl").Value) = 0, 0, adoprimaryRS.Fields("bx_yl").Value)
.Fields("保险2").Value = IIf(Len(adoprimaryRS.Fields("bx_yw").Value) = 0, 0, adoprimaryRS.Fields("bx_yw").Value)
.Update
End If
.MoveNext
Loop
End With
'strSQL = "update wkrslt2 set 常规工资=实际工时*2.39,加班工资=平时加班*2.39*1.5,休日工资=休日加班*2.39*2"
strSQL = "update wkrslt2 set 常规收入=round(实际工时*常规工资/20.92/8,1),加班工资=round(平时加班*常规工资/20.92/8*1.5,1),休日工资=round(休日加班*常规工资/20.92/8*2,1),js_date='" & DTPicker1(1).Value & "'"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 常规收入=常规工资 where 常规收入>常规工资"
mDB.ExecuteSQL strSQL
' strSQL = "update wkrslt2 set 税=0 where 税 is null"
' mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 常规工资=0 where 常规工资 is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 保险1=0 where 保险1 is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 保险2=0 where 保险2 is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set jjjs=0 where jjjs is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 常规收入=0 where 常规收入 is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 加班工资=0 where 加班工资 is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 休日工资=0 where 休日工资 is null"
mDB.ExecuteSQL strSQL
'strSQL = "update wkrslt2 set 税=常规工资+加班工资+休日工资-保险1-保险2"
strSQL = "update wkrslt2 set 税=常规收入+加班工资+休日工资-保险1"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 税=0 where 税<=800 or 税 is null"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 税=round(税*0.15-245,1) where 税>2800"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 税=round(税*0.1-105,1) where 税>1300"
mDB.ExecuteSQL strSQL
strSQL = "update wkrslt2 set 税=round(税*0.05-40,1) where 税>800"
mDB.ExecuteSQL strSQL
strSQL4 = "select * from wkrslt2"
Set adoprimaryRS4 = mDB.adoprimaryRS(strSQL4)
PrintSalary App.Path & "\tmp工资表.xls"
End Sub
Private Sub PrintSalary(ByVal sFileName As String)
'If Not (cE Is Nothing) Then Set cE = Nothing
Dim cE As New cExcel
'On Error Resume Next
On Error GoTo Err1
Dim i As Integer
Dim J As Integer
Dim iPage As Integer
Dim ii As Integer
Dim iP(30) As Integer
Dim sP(30) As String
Dim sPs As String
Dim iH(30) As Integer
Dim iHH(30) As Integer
Dim iR As Integer
Dim js_RQ As Date
Dim iYM As Integer
strSQL2 = "select * from wkrslt2"
'strSQL2 = "select id,Qname,dj_date,memo1,zman,punish1,lzman,punish2 from ls_5s,ls_taddress where ls_5s.address=ls_taddress.add_code and dj_date='" & DTPicker1(0).Value & "'"
'strSQL2 = "select id,sname,dj_date,memo1,emplyid1,zman,punish1,emplyid2,lzman,punish2 from ls_5s,ls_taddress where ls_5s.address=ls_taddress.add_code and dj_date=#" & Date & "#"
Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
If adoPrimaryRS2.RecordCount = 0 Then Exit Sub
js_RQ = adoPrimaryRS2.Fields("js_date").Value
''iPage = adoPrimaryRS2.RecordCount \ 6 + IIf(adoPrimaryRS2.RecordCount Mod 6 <> 0, 1, 0)
''ii = adoPrimaryRS2.RecordCount Mod 6
''MsgBox "报表共有" & iPage & "页，最后一页只有" & ii & "条记录。"
Dim o As New cSysForm
o.A_MES "正在处理数据，请稍候。。。。。。"
Screen.MousePointer = 11
If Len(Dir(App.Path & "\tmpSalary.xls ")) Then
cFile.ShellDelete App.Path & "\tmpSalary.xls"
End If
'cE.ExAdd App.Path & "\5s.xls", App.Path & "\hhh1.xls"
With cE
.ExAdd App.Path & "\Salary.xls", App.Path & "\tmpSalary.xls"
.ex.Visible = False
.ex.Caption = "工资报表"
'For i = 30 To 800
'.ExRowHeight i, 18
'Next i
.ex.Application.Visible = False
.ex.Application.ScreenUpdating = False
.ex.Rows("30:1000").RowHeight = 17.2
' .ExColwidth 1, 39
' .ExColwidth 2, 39
Dim RowX As Integer
Dim strTmp As String
Dim strBM As String
RowX = 30
Err2:
adoPrimaryRS2.MoveFirst
strBM = adoPrimaryRS2.Fields("dptname").Value
adoPrimaryRS2.Filter = "dptname='" & strBM & "'"
For i = 1 To adoPrimaryRS2.RecordCount '''- 1
''If i Mod 6 = 0 Then .InsertPageLine
'' If i Mod 2 = 0 Then
'' RowX = 5 * (i \ 2) + 1
''If i Mod 6 = 0 And i > 0 Then
'' .InsertPageLine "A" & CStr(RowX)
''End If
''
''.Ex.Columns("B:B").ColumnWidth = 3.75
If i > 24 Then
J = i Mod 24
Else
J = i
End If
If J = 1 Then
.ex.Rows("1:3").Select
.ex.Selection.Copy
.ex.Rows(CStr(RowX) & ":" & CStr(RowX)).Select
.ex.ActiveSheet.Paste
RowX = RowX + 3
iYM = iYM + 1
.ToExcelCell 4, RowX - 2, "部门: " & strBM
.ToExcelCell 7, RowX - 2, Year(js_RQ) & "年" & Month(js_RQ) & "月 发放日期：" & Year(DateAdd("m", 1, js_RQ)) & "年" & Month(DateAdd("m", 1, js_RQ)) & "月25日"
.ToExcelCell 21, RowX - 2, "第 " & iYM & " 页"
End If
.ToExcelCell 1, RowX, J
.ToExcelCell 3, RowX, Month(js_RQ)
.ToExcelCell 4, RowX, adoPrimaryRS2.Fields("emplyname").Value
.ToExcelCell 5, RowX, adoPrimaryRS2.Fields("常规工资").Value
.ToExcelCell 6, RowX, adoPrimaryRS2.Fields("实际工时").Value
.ToExcelCell 7, RowX, adoPrimaryRS2.Fields("常规收入").Value
.ToExcelCell 8, RowX, adoPrimaryRS2.Fields("平时加班").Value
.ToExcelCell 9, RowX, adoPrimaryRS2.Fields("加班工资").Value
.ToExcelCell 10, RowX, adoPrimaryRS2.Fields("休日加班").Value
.ToExcelCell 11, RowX, adoPrimaryRS2.Fields("休日工资").Value
' .ToExcelCell 12, RowX, Int(IIf(adoPrimaryRS2.Fields("jjjs").Value > 0, adoPrimaryRS2.Fields("jjjs").Value, 80 + 80 * Rnd))
'''.ToExcelCell 14, RowX, adoPrimaryRS2.Fields("正常天").Value * 4
.ToExcelCell 16, RowX, IIf(IsNull(adoPrimaryRS2.Fields("保险1").Value), 0, adoPrimaryRS2.Fields("保险1").Value)
.ToExcelCell 18, RowX, IIf(IsNull(adoPrimaryRS2.Fields("保险2").Value), 0, adoPrimaryRS2.Fields("保险2").Value)
' .Ex.Cells(RowX, 15) = .Ex.Cells(RowX, 7) + .Ex.Cells(RowX, 9) + .Ex.Cells(RowX, 11) + .Ex.Cells(RowX, 12) + .Ex.Cells(RowX, 13) + .Ex.Cells(RowX, 14)
' .Ex.Cells(RowX, 20) = .Ex.Cells(RowX, 16) + .Ex.Cells(RowX, 18)
' .Ex.Cells(RowX, 17) = Round(IIf(.Ex.Cells(RowX, 15) * 0.05 - 40 < 0, 0, .Ex.Cells(RowX, 15) * 0.05 - 40), 1)
' .Ex.Cells(RowX, 21) = Round(.Ex.Cells(RowX, 15) - .Ex.Cells(RowX, 17) - .Ex.Cells(RowX, 20), 0)
' .Ex.Cells(RowX, 17) = "=Round(IIf(.Ex.Cells(RowX, 15) * 0.05 - 40 < 0, 0, .Ex.Cells(RowX, 15) * 0.05 - 40), 1)"
.ex.Range("O" & CStr(RowX)).FormulaR1C1 = "=RC[-8]+RC[-6]+RC[-4]+RC[-3]+RC[-2]+RC[-1]" '''''= .Ex.Cells(RowX, 7) + .Ex.Cells(RowX, 9) + .Ex.Cells(RowX, 11) + .Ex.Cells(RowX, 12) + .Ex.Cells(RowX, 13) + .Ex.Cells(RowX, 14)
.ex.Range("T" & CStr(RowX)).FormulaR1C1 = "=RC[-4]+RC[-3]+RC[-2]"
.ToExcelCell 17, RowX, adoPrimaryRS2.Fields("税").Value
''' .Ex.Cells(RowX, 17) = Round(IIf(.Ex.Cells(RowX, 15) * 0.05 - 40 < 0, 0, .Ex.Cells(RowX, 15) * 0.05 - 40), 1)
' .Ex.Range("Q" & CStr(RowX)).FormulaR1C1 = "=round(iif((.Ex.Range(""O"" & CStr(RowX))-.Ex.Range(""P"" & CStr(RowX))) * 0.05 - 40 < 0, 0, (.Ex.Range(""O"" & CStr(RowX))-.Ex.Range(""P"" & CStr(RowX)) * 0.05 - 40),1)" '''"=RC[-2]"
' .Ex.Range("U" & CStr(RowX)).FormulaR1C1 = "=round(RC[-6]-RC[-4]-RC[-1],0)"
.ex.Range("U" & CStr(RowX)).FormulaR1C1 = "=RC[-6]-RC[-1]" ''''''"=RC[-6]-RC[-4]-RC[-1]"
' .Ex.Range("U" & CStr(RowX)).NumberFormatLocal = "0_ "
adoPrimaryRS2.Fields("flg").Value = 1
adoPrimaryRS2.Update
If J = 24 Then
.ex.Rows("28:29").Copy
.ex.Rows(CStr(RowX + 1) & ":" & CStr(RowX + 1)).Select
.ex.ActiveSheet.Paste
RowX = RowX + 2
.InsertPageLine "A" & CStr(RowX + 1)
End If
adoPrimaryRS2.MoveNext
RowX = RowX + 1
Next i
If J < 24 Then
RowX = RowX + 24 - J
End If
' RowX = RowX + 1
.ex.Rows("28:29").Copy
.ex.Rows(CStr(RowX) & ":" & CStr(RowX)).Select
.ex.ActiveSheet.Paste
RowX = RowX + 2
.InsertPageLine "A" & CStr(RowX)
adoPrimaryRS2.Filter = "flg=0"
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -