如何实现excel与outlook互通

如何实现excel与outlook互通

Boolean Public Sub SVfromVerifyen(item As Outlook.MailItem) Dim myattachment mysuj = item.Subject itemBody2 = "" itemBody2 = item.Body mysender = item.SenderEmailAddress attaname = "" myattachment = "" Dim n3 As Integer For Each myattachment In item.Attachments If myattachment.Size > 0 Then If myattachment.FileName Like "*.jpg" Or myattachment.FileName Like "*.png" Then flagifhasatta = True Else n3 = n3 + 1 attaname = attaname & "<<"

private mysuj, mysender, attaname, itembody2 dim attacount2 as integer dim mi4 as string dim flagifhasatta as boolean public sub svfromverifyen(item as outlook.mailitem) dim myattachment mysuj = item.subject itembody2 = "" itembody2 = item.body mysender = item.senderemailaddress attaname = "" myattachment = "" dim n3 as integer for each myattachment in item.attachments if myattachment.size > 0 then if myattachment.filename like "*.jpg" or myattachment.filename like "*.png" then flagifhasatta = true else n3 = n3 + 1 attaname = attaname & "<<" & myattachment.filename & ">> " end if end if next myattachment attacount2 = 0 if n3 = 0 then attacount2 = 0 else attacount2 = n3 end if if len(attaname) > 0 then flagifhasatta = false else flagifhasatta = true goto 110: end if dim mi2 as integer dim mi3 as integer dim mi5 as integer mi4 = "" mi3 = len(mysuj) mi2 = instr(1, mysuj, "", vbtextcompare) if mi2 and mi5 then mi4 = mid(mysuj, int(mi2) + 3, (int(mi5) - int(mi2)) - 3) else exit sub end if rem 以下是字典 rem 以下是字典 set dt = createobject("scripting.dictionary") dt.add "ping.zhang@xxxxx.us", "enpingzhangverify" dt.add "lucywang2015@xxxx.com", "enlucyverify" dt.add "mi_chen@xxxxx.com", "michentest" dim addsavefolder2 if dt.exists(mysender) then addsavefolder2 = dt(mysender) end if set yyy = createobject("scripting.filesystemobject") if yyy.folderexists("d:\工作总结\201\" & mi4 & "\英语校验返回\" & addsavefolder2) = false then if len(attaname) > 0 then on error goto 100 mkdir "d:\工作总结\接管\" & mi4 & "\英语校验返回\" & addsavefolder2 end if end if if len(attaname) > 0 then saveattachment item, "d:\工作总结\作接管\" & mi4 & "\英语校验返回\" & addsavefolder2 & "\", "*" msgbox mi4 & chr(10) & "自动保存英语校验稿成功" end if rem 以上是字典 dim mi222 as integer dim mi333 as integer dim mi444 as string dim mi555 as integer dim mi666 as integer dim mi777 as integer dim mi888 as string mi444 = "" mi333 = len(mysuj) mi222 = instr(1, mysuj, "", vbtextcompare) if mi222 > 0 and mi555 > 0 then mi444 = mid(mysuj, int(mi222) + 3, (int(mi555) - int(mi222)) - 3) mi666 = instr(10, mi444, "_", vbtextcompare) mi777 = instr(mi666 + 1, mi444, "_", vbtextcompare) mi888 = mid(mi444, mi666 + 1, (mi777 - mi666) - 1) else msgbox mysuj & chr(10) & "id被破话，无法保存英语校验附件，需要手工处理" exit sub end if if len(attaname) > 0 then open "d:\工作总结\20160429翻译工作接管\" & mi4 & "\log.txt" for append as #1 write #1, "保存英语校验", mi888, mysender, attaname, now() close #1 open "d:\工作总结\20160429翻译工作接管\" & mi4 & "\英语校验返回\log.txt" for append as #10 write #10, "保存英语校验", mi888, mysender, attaname, now() call 校验接收奖金计算en rem above add on 15nov16 close #10 end if rem 新加的 110: dim miend miend = 20 if miend < 0 or miend = 0 or miend > 50 then miend = instr(1, item.body, "_", vbtextcompare) elseif miend < 0 or miend = 0 or miend > 50 then miend = instr(1, item.body, "<", vbtextcompare) elseif miend < 0 or miend = 0 or miend > 50 then miend = instr(1, item.body, "-", vbtextcompare) elseif miend < 0 or miend = 0 or miend > 50 then miend = 20 else miend = 20 end if if flagifhasatta = true then rem add dim mi22 as integer dim mi32 as integer dim mi52 as integer dim mi42 mi32 = len(mysuj) mi22 = instr(1, mysuj, "", vbtextcompare) if mi22 and mi52 then mi42 = mid(mysuj, int(mi22) + 3, (int(mi52) - int(mi22)) - 3) end if rem add open "d:\工作总结\20160429翻译工作接管\" & mi42 & "\log.txt" for append as #49 write #49, "英语校验邮件返回但没有附件具体看邮件", mi888, mysender, now(), mid(item.body, 1, miend) call 校验接收奖金计算en rem above add on 15nov16 close #49 rem add set yyy = createobject("scripting.filesystemobject") if yyy.folderexists("d:\工作总结\201管\" & mi42 & "\英语校验返回") = true then rem add open "d:\工作总结\20160429\" & mi42 & "\英语校验返回\log.txt" for append as #44 write #44, "英语校验邮件返回但没有附件具体看邮件", mi888, mysender, now(), mid(item.body, 1, miend) close #44 else msgbox "英语校验返回_文件夹不存在,写log已经失败！" end if exit sub end if rem 新加的 set myattachment = nothing set item = nothing mysender = "" attaname = "" exit sub 100: msgbox "目标文件夹不存在，无法存盘" & chr(10) & mi4 & chr(10) & "保存英语校验附件失败，可能要手工存盘" end sub ' 保存附件 ' path为保存路径，condition为附件名匹配条件 private sub saveattachment(byval item as object, path$, optional condition$ = "*") dim olatt as attachment dim i as integer if item.attachments.count > 0 then for i = 1 to item.attachments.count set olatt = item.attachments(i) ' save the attachment if olatt.filename like condition then olatt.saveasfile path & olatt.filename end if next end if set olatt = nothing end sub sub 校验接收奖金计算en() dim mi2 as integer dim mi3 as integer dim mi4 as string dim mi5 as integer mi3 = len(mysuj) mi2 = instr(1, mysuj, "", vbbinarycompare) mi4 = mid(mysuj, int(mi2) + 3, (int(mi5) - int(mi2)) - 3) dim mi222 as integer dim mi333 as integer dim mi444 as string dim mi555 as integer dim mi666 as integer dim mi777 as integer dim mi888 as string mi333 = len(mysuj) mi222 = instr(1, mysuj, "", vbbinarycompare) mi444 = mid(mysuj, int(mi222) + 3, (int(mi555) - int(mi222)) - 3) mi666 = instr(10, mi444, "_", vbbinarycompare) mi777 = instr(mi666 + 1, mi444, "_", vbbinarycompare) mi888 = mid(mi444, mi666 + 1, (mi777 - mi666) - 1) open "d:\工作总结\20160429翻译工作接管\" & mi4 & "\receivemailbonuslog.txt" for append as #40 write #40, mi888, "检验返回接收", mysender, "奖励计算", attaname, attacount2, now() close #40 open "d:\工作总结\20管\境外奖金计算\receivemailbonuslog.txt" for append as #45 write #45, mi888, "检验返回接收", mysender, "接收奖励计算", attaname, attacount2, now(), mid(itembody2, 1, 100) close #45 接收数据写入excela mi888, "检验返回接收", mysender, "接收奖励计算", attaname, attacount2, now(), mid(itembody2, 1, 200) end sub sub 接收数据写入excela(a, b, c, d, e, f as integer, g, h) set conn = createobject("adodb.connection") set rst = createobject("adodb.recordset") conn.open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & "d:\工作总结\奖金计算" & "/奖励计算数据库.xls" rst.open "select * from [返回$]", conn, , adlockoptimistic rst.addnew rst.fields("日期") = cdate(format(now(), yyyy - mm - dd)) rst.fields("项目名称") = mid(a, 1, 200) rst.fields("动作") = b rst.fields("校验返稿发件人") = mid(c, 1, 200) rst.fields("奖励标识") = d rst.fields("所有语言附件名称") = mid(e, 1, 200) rst.fields("所有语言附件数") = cint(f) rst.fields("时间戳") = g rst.fields("邮件内容") = h rst.fields("邮件数") = cint(1) rst.update rst.close conn.close set rst = nothing set conn = nothing msgbox "已输入到奖励数据库" end sub