Dim year As String = e.F orm.Controls("所属年").Value
Dim moth As String = e.F orm.Controls("所属月").Value
If year = "" OrElse moth = "" Then
Messagebox.show("请选择工资报表所属的年和月,如果需要查询全年工资,请点击历史工资表选项!","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)
Return
End If
e.Form.Controls("WebBrowser1").Visible = True
Dim wbr As WinForm.WebBrowser = e.F orm.Controls("WebBrowser1")
wbr.AddRess = Nothing
Dim cmd As New SQLCommand
Dim dt As DataTable
Dim cmb As WinForm.ComboBox
cmd.C
cmd.CommandText = "SELECT DISTINCT 企业名称 F rom {企业信息}"
Dim Values = cmd.ExecuteValues
If Values.Count > 0 Then
Vars("qymc") = Values("企业名称")
End If
Dim filter As String = "类别 = '结算方式' And 名称 like '%上海农商银行%'"
Dim ds0 As DataTable
cmd.C
cmd.CommandText = "SELECT * F rom {部门明细}"
ds0 = cmd.ExecuteReader()
Dim Names As List(Of DataRow) = ds0.Select(filter)
Dim Sum As String
Dim dytj As String
Dim ci As Integer
If Names.Count > 0 Then
For ci = 1 To Names.Count-1
sum = Sum & " or 银行账号 Like '" & Names(ci)("代码") & "%'"
Next
dytj = "银行账号 Like '" & Names(0)("代码") & "%'" & sum
End If
Dim r As Row = Tables("工资报表_Table1").Current
Dim tmp As String = ProjectPath & "Attachments\工资清单.xls"
Dim tmp1 As String = ProjectPath & "Attachments\银行接口报表.xls"
Dim tmp2 As String = ProjectPath & "Attachments\工资签收单.xls"
Dim rpt1 As String = "d:/工资/" + (r("所属年份")) + (r("所属月份")) + "01.xls"
Dim rpt2 As String = "d:/工资/" + (r("所属年份")) + (r("所属月份")) + "无卡签收表.xls"
Dim pdf As String = "d:/工资/temp/" + (r("所属年份"))+ "年" + (r("所属月份")) +"月工资报表.pdf"
Dim rpt As String = "d:/工资/" + (r("所属年份")) + (r("所属月份")) + "工资清单.xls"
FileSys.CreateDirectory("d:/工资/temp")
If FileSys.FileExists(rpt) = True Then
FileSys.DeleteFile(rpt)
End If
If FileSys.FileExists(rpt1) = True
FileSys.DeleteFile(rpt1)
End If
If FileSys.FileExists(rpt2) = True
FileSys.DeleteFile(rpt2)
End If
If FileSys.FileExists(pdf) = True
FileSys.DeleteFile(pdf)
End If
If FileSys.FileExists(rpt) = False Then
Dim Book As New XLS.Book(tmp)
Book.Build()
Book.Save(rpt) '保存为XLS文件
End If
If FileSys.FileExists(rpt2) = False Then
Dim Book1 As New XLS.Book(tmp2)
Book1.Build()
Book1.Save(rpt2)'保存为XLS文件
End If
Dim App1 As New MSExcel.Application
Dim App2 As New MSExcel.Application
try
Dim Wb1 As MSExcel.WorkBook = App1.WorkBooks.Open(rpt)
Dim Wb2 As MSExcel.WorkBook = App2.WorkBooks.Open(rpt2)
Dim Ws1 As MSExcel.WorkSheet = Wb1.WorkSheets(1) '指定要复制的工作表
Dim Ws2 As MSExcel.WorkSheet = Wb2.WorkSheets(1)
Ws2.UsedRange.Copy
ws1.Select
Dim count As Integer = Ws1.UsedRange.Rows.Count+1
Ws1.Rows(count).PageBreak = MSExcel.XlPageBreak.xlPageBreakManual
'ws1.Cells(1,Ws1.UsedRange.Columns.Count).Select '横向拷贝
ws1.Cells(count,1).Select '纵向拷贝
ws1.paste
For i As Integer = count To Ws1.UsedRange.Rows.Count
If ws1.cells(i,1).Text.Contains("本页合计") Then
If i < Ws1.UsedRange.Rows.Count Then
Ws1.Rows(i+1).PageBreak = MSExcel.XlPageBreak.xlPageBreakManual
End If
End If
Next
wb1.Save
wb2.Save
wb1.ExportAsFixedFormat(MSExcel.XlFixedFormatType.xlTypePDF,pdf,MsExcel.XlFixedFormatQuality.xlQualityStandard,True, False,System.Reflection.Missing.Value,System.Reflection.Missing.Value,False,System.Reflection.Missing.Value)
'app1.visible = True
app1.quit
app2.quit
catch ex As exception
msgbox(ex.message)
app1.quit
app2.quit
End try
If FileSys.FileExists(rpt1) = False Then
Dim Book2 As New XLS.Book(tmp1)
Dim Sheets As XLS.Sheet = Book2.Sheets(0)
Sheets(1,5).Value = "<" & dytj & ">" '写入打印条件
Book2.Build()
Book2.Save(rpt1)'保存为XLS文件
Dim Appl As New MSExcel.Application
Dim Wba As MSExcel.WorkBook = Appl.WorkBooks.Open(rpt1)
Dim Wsa As MSExcel.WorkSheet = Wba.WorkSheets(1)
Dim Rt As MSExcel.Range = Wsa.UsedRange
Dim r1 As String = CStr(Rt.Rows.Count + 3)
Dim r2 As String = CStr(Rt.Rows.Count)
Dim sr As String = CStr(Rt.Rows.Count + 4)
Dim s As String = "A2:D" &r2
Dim w As String = "1:" &r1
Dim rw As String = "F" &sr
Dim Rs As MSExcel.Range = Wsa.Range(s)
Rs.Cut(Wsa.Range(rw))
Dim Rg As MSExcel.Range = Wsa.Rows(w)'选定多行
Rg.Delete(MSExcel.XlDirection.xlUp) '下面的单元格上移
Rg = Wsa.Columns("A:E") '选定多列
Rg.Delete(MSExcel.XlDirection.xlToLeft) '右面的单元格左移
Wba.Save
Appl.quit
End If
wbr.AddRess = pdf
此主题相关图片如下：02.jpg
[此贴子已经被作者于2023/8/30 15:54:02编辑过]
加好友 
发短信
Post By：2023/8/30 15:48:00 [显示全部帖子]
