注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

奕克

爱家人爱工作爱生活

 
 
 

日志

 
 

使用VBA批量自动收集email邮件附件中的数据  

2013-04-15 19:17:13|  分类: office |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
      今年带毕业班,需要让学生们填写就业意向表,格式如下,但他们都出去各地实习了,怎么样更省力的收集这些信息呢?
      使用VBA批量自动收集email邮件附件中的数据 - wucccsk - 天秤的存在与虚无博客
    首先让他们各自填写这个excel文件,然后将文件以自己的名字命名,做为附件发送email给我。注意要求他们一定将邮件的标题设置为包含“就业意向表”几个字,后面我的程序可以以此做为关键字过滤出这些目标邮件。
    在他们发完邮件后,首先设置outlook2003的邮件帐户,然后接收所有邮件,具体步骤可以谷歌。然后进入outlook2003的vba环境,创建一个宏,将如下代码拷入,执行时,输入要读取的邮件标题关键字和这些邮件的附件要保存在哪个目录,程序会自动保存这些邮件的附件并将该邮件标记为已读:

Sub getmailattachment()
myFilter = InputBox("请输入邮件标题的过滤关键字:", , "就业意向表")
folder = InputBox("请输入邮件附件的保存目录:", , "c:\vbamail")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For Each mymailitem In myFolder.Items
   If mymailitem.UnRead Then
    If InStr(mymailitem.Subject, myFilter) Then
     mymailitem.UnRead = False
     If mymailitem.Attachments.Count > 0 Then
      For Each att In mymailitem.Attachments
        Path = folder & "\" & mymailitem.Subject & "-" & att.FileName
        att.SaveAsFile Path
      Next
      Else
       MsgBox mymailitem.SenderEmailAddress & "无附件"
     End If
    End If
  End If
Next
MsgBox "完工了"
End Sub
 
      由于时间因素,没有将其做成vbs脚本,所以不能脱离outlook vba环境运行,这样得到的是每个同学格式一样的,各自独立的就业意向表excel文件,存在同一个文件夹下。
      然后参考我的另一篇日志:一个合并同一目录下所有excel数据的vbs小程序(http://wucccsk.blog.163.com/blog/static/1734198452012821111256146/)。
     也就是新建文本文档,将如下的代码拷入后,另存为扩展名为.vbs的宏脚本,双击运行,输入独立的每个excel文件表格的标题所占行数,在就业意向表这种情况下为1,程序自动合并同一目录下所有的excel表格数据,生成一个“合并.xls“的excel文件。这样就完成了大批量数据的半自动化收集任务,用于收集各类分散数据的话,程序还是比较通用的。

x=inputbox("请输入每个文件表头所占的行数:")

Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
set xlsapp = CreateObject("excel.Application")
xlsapp.visible=true
set hb=xlsapp.workbooks.add
hb.saveas(WshShell.CurrentDirectory & "\合并.xls")
Set myfolder = fso.GetFolder(WshShell.CurrentDirectory)
index=1
For Each myfile In myfolder.Files
  if InStr(myfile.name,".xls")<>0 and InStr(myfile.name,"合并.xls")=0 and InStr(myfile.name,"$")=0  then
   set temp=xlsapp.workbooks.open(WshShell.CurrentDirectory & "\" & myfile.name)
   if index=1 then
     temp.Worksheets(1).Rows("1:" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   else
     temp.Worksheets(1).Rows((x+1) & ":" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   end if
   hb.Worksheets(1).Rows(index).PasteSpecial
   fnl=Len(myfile.Name)
   For i = index To hb.Worksheets(1).UsedRange.Rows.Count
      hb.Worksheets(1).Cells(i,temp.Worksheets(1).UsedRange.Columns.Count+1).Value = Left(myfile.Name,fnl-4)
   Next
   hb.Save
   index=hb.Worksheets(1).UsedRange.Rows.Count+1
   temp.close
   set temp=Nothing
  end if
next
hb.worksheets(1).columns.autofit
hb.save
hb.close
set hb=nothing
set myfolder=nothing
xlsapp.quit
Set xlsapp= Nothing
Set fso = Nothing
Set wshell = Nothing 
MsgBox "OK,请打开合并.xls"
  评论这张
 
阅读(2243)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017