ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 7282|回复: 7

[求助] 请诊断以下代码:自动保存附件

[复制链接]

TA的精华主题

TA的得分主题

发表于 2011-5-10 12:36 | 显示全部楼层 |阅读模式
Outlook2003,“规则和通知”中,
规则:带有附件
运行:脚本
功能:
当发件人邮件地址中含有"zhangsan"时,把附件保存到目录:"f:\outlook\attachment\张三\"
当发件人邮件地址中含有"lisi"时,把附件保存到目录:"f:\outlook\attachment\李四\"
否则,把附件保存到目录:"f:\outlook\attachment\未分组\"

脚本参考:
http://blog.ipodmp.com/archives/ ... y-save-attachments/

脚本:
  1. Public Sub SaveAttach(Item As Outlook.MailItem)

  2.     Dim RootPath, NewF, NewPath
  3.    
  4. Select Case Item.SenderEmailAddress
  5.    
  6.     Case InStr(Item.SenderEmailAddress, "zhangsan") > 0
  7.    
  8.         RootPath = "f:\outlook\attachment\张三"
  9.    
  10.     Case InStr(Item.SenderEmailAddress, "lisi") > 0
  11.    
  12.         RootPath = "f:\outlook\attachment\李四"
  13.                
  14.     Case Else
  15.         
  16.         RootPath = "f:\outlook\attachment\未分组"
  17.         
  18.     End Select
  19.    
  20.    
  21.     NewF = Date & "." & Item.Subject
  22.     NewPath = RootPath & NewF & ""

  23.     SaveAttachment Item, NewPath, "*.*"
  24. End Sub

  25.    

  26. ' 保存附件函数
  27. ' path为保存路径,condition为附件名匹配条件
  28. Private Sub SaveAttachment(ByVal Item As Object, ByVal path As String, Optional condition = "*")
  29.     Dim olAtt As Attachment
  30.     Dim i As Integer
  31.     '检查文件夹是否存在,不存在就新建
  32.     Dim fso, f
  33.     Set fso = CreateObject("Scripting.FileSystemObject")
  34.     If fso.FolderExists(path) <> True Then
  35.         fso.CreateFolder (path)
  36.     End If
  37.     '循环保存附件
  38.     If Item.Attachments.Count > 0 Then
  39.         For i = 1 To Item.Attachments.Count
  40.             Set olAtt = Item.Attachments(i)
  41.             If olAtt.FileName Like condition Then
  42.                 olAtt.SaveAsFile path & olAtt.FileName
  43.             End If
  44.         Next
  45.     End If
  46.     MsgBox "此次保存 " & Item.Attachments.Count & " 个对象."
  47.     Set olAtt = Nothing
  48. End Sub

  49. '该函数自动补充不足的"0″
  50. Function RLeft(sval)
  51.     RLeft = Right("00" & CStr(sval), 2)
  52. End Function
复制代码
运行结果:
全部附件都保存到了"f:\outlook\attachment\未分组\"目录。

求高手帮忙看看哪不对,谢谢!

TA的精华主题

TA的得分主题

发表于 2011-5-10 16:12 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
不能用select case,

用if else

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-5-10 16:27 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
改成if else后好了,多谢。
还有个问题:
RootPath = "f:\outlook\attachment\未分组" & year(date) & “\" &  month(date) & "\"
为什么不行?去掉其中的两个 "\" 就又行了。

[ 本帖最后由 jour 于 2011-5-10 16:30 编辑 ]

TA的精华主题

TA的得分主题

发表于 2011-5-10 19:58 | 显示全部楼层
你想存成什么样子?
举个例子

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-5-11 07:58 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
就是想把未分组附件按年、月目录存放

TA的精华主题

TA的得分主题

发表于 2011-5-11 09:03 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
& Year(Date) & "\" & Month(Date) & "\"

这个我试了,没问题啊。

TA的精华主题

TA的得分主题

发表于 2015-11-5 10:49 | 显示全部楼层
dsd999 发表于 2011-5-11 09:03
& Year(Date) & "\" & Month(Date) & "\"

这个我试了,没问题啊。

那请教,完整的代码是什么呢?为什么我在office outlook2007里就执行不了?

TA的精华主题

TA的得分主题

发表于 2015-11-5 10:50 | 显示全部楼层
jour 发表于 2011-5-10 16:27
改成if else后好了,多谢。
还有个问题:
RootPath = "f:\outlook\attachment\未分组" & year(date) & “ ...

怎么改成IF ELSE?
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 05:22 , Processed in 0.044246 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表