|
'报告转换程序V1.4
'本脚本用来生成报告。
'作者：程鹤
'创建时间：20010年4月7日
'更新时间时间：2010年4月7日
'使用方法： 修改本脚本的参数部分，添加计划任务，每日下午运行此脚本。
'需要安装Excel 2007
'=============================请修改以下参数==========================
const errorLogFile = ".\error.log" '此脚本的错误日志，记录此脚本的错误信息
Const TemplateXLT = "E:\Scripting\Template.xltx" 'Excel模板，要用绝对路径
Const ReportXLS = "E:\Scripting\Reports\QuizReport" '最终报告的文件夹和文件名前缀，程序自动添加日期，和扩展名.xls，要用绝对路径
Const FromAddress = """CRM Quiz Report"" "
ToAddress = "a@guyanhanzhi.com," &_ '收件人地址
"b@guyanhanzhi.com"
aBody = "大家好,附件中是今日***的报表，请查看。" & _ '邮件正文
"一些文本一个链接，" & _
"
DateString = year(now()) & "-" & month(now())& "-" & day(now())
aSubject = "***Report " & DateString '邮件标题
AttachFile = ReportXLS & DateString & ".xls" '生成的Excel文件，也是邮件的附件
'=============================请修改以上参数==============================
on error resume next
'启动脚本运行错误的日志文件
Set objFS = CreateObject ("Scripting.FileSystemObject")
if objFS.FileExists(errorLogFile) then
objFS.DeleteFile(errorLogFile)
end if
Set objErrLog = objFS.CreateTextFile(errorLogFile)
'=========================================================================================================================
err.Number = 0
Set ExcelApp = CreateObject("Excel.Application") '创建EXCEL对象
if err.Number <> 0 then
objErrLog.WriteLine "创建Excel.Application时发生错误"
End if
ExcelApp.DisplayAlerts = False '关掉Excel的操作提示，比如当删除一些内容时的确认对话框
ExcelApp.visible = False '操作Excel时窗口不可见，调试时可以打开
err.Number = 0
set ExcelBook = ExcelApp.Workbooks.add(TemplateXLT)
if err.Number <> 0 then
objErrLog.WriteLine "以" & TemplateXLT & "为模板创建Excel工作簿时发生错误，找不到此模板，或禁止访问"
End if
err.Number = 0
'Excelbook.Activate
With Excelbook '对Excel工作簿的处理
.RefreshAll '更新工作簿里面的数据链接
.Sheets("sheetname1").Select '选中工作表
.Sheets("sheetname1").Cells.Select '选中工作表中所有单元格
ExcelApp.Selection.SpecialCells(12).Select '选中工作表中所有可见单元格
ExcelApp.Selection.Copy '复制
.Sheets("sheetname2").Select
.Sheets("sheetname2").Cells.Select '粘贴值
ExcelApp.Selection.PasteSpecial -4163, -4142, False, False
.Sheets("sheetname3").Select
.Sheets("sheetname3").Cells.Select
ExcelApp.Selection.Copy
ExcelApp.Selection.PasteSpecial -4163, -4142, False, False
.Sheets("sheetname3").AutoFilter.Sort.SortFields.Add .Sheets("sheetname3").Range("D1"), 0, 2, 0 '添加自动过滤
With .Sheets("sheetname3").AutoFilter.Sort '对自动过滤进行排序
.Header =1
.MatchCase=False
.Orientation=1
.SortMethod=1
.Apply
End With
.Sheets("sheetname4").Select
.Sheets("sheetname4").Cells.Select
ExcelApp.Selection.Copy
ExcelApp.Selection.PasteSpecial -4163, -4142, False, False
.Sheets("sheetname5").Select
.Sheets("sheetname5").Cells.Select
ExcelApp.Selection.Copy
ExcelApp.Selection.PasteSpecial -4163, -4142, False, False
.Connections("DatabaseConnection1").Delete '删除数据链接
.Sheets("sheetname1").Delete '删除多余的工作表
.Sheets("sheetname2").Delete
.Sheets("sheetname3").Delete
End With
err.Number = 0
ExcelBook.SaveAs AttachFile,56 '另存工作表为当日报告,Excel 2003兼容
if err.Number <> 0 then
objErrLog.WriteLine "不能保存工作簿，目标文件夹不能访问" & ReportXLS
End if
ExcelBook.close
excelApp.Quit
err.Number = 0
Sendmail FromAddress,ToAddress,aSubject,aBody,AttachFile '发送电子邮件
if err.Number <> 0 then
objErrLog.WriteLine "发送电子邮件错误"
End if
set ExcelSheet=nothing
set ExcelBook=nothing
set excelApp=nothing
Set objErrLog = nothing
Sub Sendmail(FromAddress,ToAddress,aSubject,aBody,AttachFile) '发送电子邮件
Const cdoSendUsingPickup = 1 '用本地SMTP发送.
Const cdoSendUsingPort = 2 '用远程SMTP发送.
Const cdoAnonymous = 0 '匿名认证
Const cdoBasic = 1 'basic 认证
Const cdoNTLM = 2 'NTLM 认证
Set objMessage = CreateObject("CDO.Message")
'========消除乱码开始======
objMessage.BodyPart.Charset = "gb2312"
objMessage.BodyPart.Fields.Item _
("urn:schemas:mailheader:content-transfer-encoding") = "base64"
objMessage.BodyPart.Fields.Update
'=======消除乱码结束=====
objMessage.Subject = aSubject '邮件主题
objMessage.From = FromAddress '发件人objMessage.To = ToAddress '收件人
objMessage.HtmlBody = aBody 'HTML邮件正文
objMessage.Addattachment AttachFile
'==这部分提供远程SMTP服务器配置信息==
objMessage.Configuration.Fields.Item _
("") = 2
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("") = "smtp.guyanhanzhi.com"
'Type of authentication, NONE, Basic (Base64 encoded), NTLM
objMessage.Configuration.Fields.Item _
("") = cdoBasic
'访问SMTP服务器的用户名
objMessage.Configuration.Fields.Item _
("") = "mailuser"
'访问SMTP服务器的密码
objMessage.Configuration.Fields.Item _
("") = "mailpassword"
'服务器端口(典型为25)，465为SSL加密的SMTP端口
objMessage.Configuration.Fields.Item _
("port") = 465
'使用SSL连接
objMessage.Configuration.Fields.Item _
("") = True
'连接超时秒数
objMessage.Configuration.Fields.Item _
("") = 60
objMessage.Configuration.Fields.Update
'==远程SMTP服务器配置结束==
objMessage.Send
End Sub
|
