求助:用VBA提取outlook邮件的指定内容到Excel单元格

卧枝惠中天 2019-03-24 07:24:21
用VBA提取outlook邮件的指定内容到Excel单元格

目标邮件:outlook下收件箱aa目录下的bb文件夹,bb文件夹里面会有多封邮件,数量不定
邮件内容大概如下:
abcabcabcabd....
abcabcabcabd....
SKU:********
数量:**
abcabcabcabd....
abcabcabcabd....

现在需要提取关键字为“SKU:”和“数量:”后面的值,
并把取得的值依次写入excel的A列和B列,
如果写入成功,就把处理完的邮件移动到bb文件夹下面的cc文件夹里。

这两天多次查资料也没能解决,希望大神指导一下哦~
...全文
4781 17 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
17 条回复
切换为时间正序
请发表友善的回复…
发表回复
weixin_42199462 2020-12-14
  • 打赏
  • 举报
回复
看了您的帖子很受启发。 请问如果想取的数据是表格格式的该怎么办呢?比如在邮件正文中,A列是表头,B列是我想要取的值,且其文本的格式不固定,可能包含数字字母或标点符号。 谢谢!
引用 7 楼 milaoshu1020 的回复:
刚才的差了一个^符号,这是修改后的:

Sub test()
    Dim outlook
    Set outlook = CreateObject("outlook.application")
    
    Dim ns
    Set ns = outlook.getnamespace("MAPI")
    
    Dim objfolder
    Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")
    
    Dim objfolder2
    Set objfolder2 = objfolder.Folders("CC")
    
    Dim reg
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True
    reg.ignorecase = True
    reg.MultiLine = True
    reg.Pattern = "^SKU:(.*)(?:\r?\n)+数量:(.*)$"
    
    Dim r
    r = 1
    
    Range("A:B").Clear
    
    Dim i
    For i = objfolder.items.Count To 1 Step -1
        Dim item
        Set item = objfolder.items(i)
        
        If reg.test(item.body) Then
            Dim colmatches
            Set colmatches = reg.Execute(item.body)
            
            Dim objmatch
            For Each objmatch In colmatches
                Cells(r, 1) = objmatch.submatches(0)
                Cells(r, 2) = objmatch.submatches(1)
                r = r + 1
            Next
    
            item.Move objfolder2
        End If
    Next
    
    MsgBox "Done!"

End Sub
下载地址: 链接:https://pan.baidu.com/s/1O5HQOvhooJCoIAuHJ3esRQ 提取码:lzvp
milaoshu1020 2020-02-17
  • 打赏
  • 举报
回复
引用 15 楼 qq_46327034 的回复:
那么vbs执行时,执行到if reg.test(item.body) Then 语句报错说未指定的错误 80004005,这个可以怎么破么?不好意思我是小白..

这个错误是说你没有权限,需要提权;
qq_46327034 2020-02-17
  • 打赏
  • 举报
回复
那么vbs执行时,执行到if reg.test(item.body) Then 语句报错说未指定的错误 80004005,这个可以怎么破么?不好意思我是小白..
引用 14 楼 milaoshu1020 的回复:
没权限可以申请权限,你要是创建不了对象就什么事也干不了;
qq_46327034 2020-02-14
  • 打赏
  • 举报
回复
[quote=引用 7 楼 milaoshu1020 的回复:] 我用上面的vbs执行时,执行到if reg.test(item.body) Then 语句报错说未指定的错误 80004005。用上面的vba执行时,直接报错说ActiveX component can't create object。请问大神可以怎么解决吗?
qq_46327034 2020-02-14
  • 打赏
  • 举报
回复
我用上面的vbs执行时,执行到if reg.test(item.body) Then 语句报错说未指定的错误 80004005。用上面的vba执行时,直接报错说ActiveX component can't create object。请问大神可以怎么解决吗?
milaoshu1020 2020-02-14
  • 打赏
  • 举报
回复
引用 13 楼 qq_46327034 的回复:
非常感谢大神!公司电脑,没有admin权限.. 同时可以问下VBS 那个问题可以怎么破么?[握拳][握拳]

没权限可以申请权限,你要是创建不了对象就什么事也干不了;
qq_46327034 2020-02-14
  • 打赏
  • 举报
回复
非常感谢大神!公司电脑,没有admin权限.. 同时可以问下VBS 那个问题可以怎么破么?[握拳][握拳]
引用 12 楼 milaoshu1020 的回复:
上边的代码有点问题,更改如下:

If wscript.arguments.count = 0 Then
    Dim sh
    Set sh = createobject("shell.application")
    sh.shellexecute wscript.fullname,"""" & wscript.scriptfullname & """ -admin",,"runas"
    wscript.quit
End If
milaoshu1020 2020-02-14
  • 打赏
  • 举报
回复
上边的代码有点问题,更改如下:

If wscript.arguments.count = 0 Then
Dim sh
Set sh = createobject("shell.application")
sh.shellexecute wscript.fullname,"""" & wscript.scriptfullname & """ -admin",,"runas"
wscript.quit
End If
milaoshu1020 2020-02-14
  • 打赏
  • 举报
回复
引用 9 楼 qq_46327034 的回复:
我用上面的vbs执行时,执行到if reg.test(item.body) Then 语句报错说未指定的错误 80004005。用上面的vba执行时,直接报错说ActiveX component can't create object。请问大神可以怎么解决吗?

这个错误的意思是没有权限无法创建对象,需要用管理员身份运行脚本或者Excel;

至于如何以管理员身份运行,你可以在脚本的最前边加上如下语句:
If wscript.arguments.count = 0 Then
Dim sh
Set sh = createobject("shell.application")
sh.shellexecute wscript.fullname,"""" & wscript.scriptfullname & """ -install",,"runas"
End If
卧枝惠中天 2019-04-01
  • 打赏
  • 举报
回复
引用 7 楼 milaoshu1020 的回复:
谢谢大神,太给力了,提高了不少效率!!!代码的部分内容我还需要学习理解一下。
卧枝惠中天 2019-03-29
  • 打赏
  • 举报
回复
引用 4 楼 milaoshu1020 的回复:
非常感谢,可以处理邮件了。 测试的时候,我放了20封邮件到文件夹,运行vba后处理了3个,还有2个没有处理。 需要多次执行vba才可以把邮件都处理完。 这里我试着先获取所有邮件信息,然后一封一封处理,结果没整出来,老是报错。 还有就是如果一封邮件里面有多个 abcabcabcabd.... abcabcabcabd.... SKU:******** 数量:** abcabcabcabd.... abcabcabcabd.... abcabcabcabd.... abcabcabcabd.... SKU:******** 数量:** abcabcabcabd.... abcabcabcabd.... 。 。 。 这样的请运行vba的话会显示处理完成,但是没有取得数据,邮件也没有被移动到完成的文件夹里面。 这里是不是应该使用数组?这个不太懂,还请大神指教,不胜感激!!!
milaoshu1020 2019-03-29
  • 打赏
  • 举报
回复
刚才的差了一个^符号,这是修改后的:

Sub test()
Dim outlook
Set outlook = CreateObject("outlook.application")

Dim ns
Set ns = outlook.getnamespace("MAPI")

Dim objfolder
Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")

Dim objfolder2
Set objfolder2 = objfolder.Folders("CC")

Dim reg
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.MultiLine = True
reg.Pattern = "^SKU:(.*)(?:\r?\n)+数量:(.*)$"

Dim r
r = 1

Range("A:B").Clear

Dim i
For i = objfolder.items.Count To 1 Step -1
Dim item
Set item = objfolder.items(i)

If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.Execute(item.body)

Dim objmatch
For Each objmatch In colmatches
Cells(r, 1) = objmatch.submatches(0)
Cells(r, 2) = objmatch.submatches(1)
r = r + 1
Next

item.Move objfolder2
End If
Next

MsgBox "Done!"

End Sub

下载地址:
链接:https://pan.baidu.com/s/1O5HQOvhooJCoIAuHJ3esRQ
提取码:lzvp
milaoshu1020 2019-03-29
  • 打赏
  • 举报
回复
修改好了:

Sub test()
Dim outlook
Set outlook = CreateObject("outlook.application")

Dim ns
Set ns = outlook.getnamespace("MAPI")

Dim objfolder
Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")

Dim objfolder2
Set objfolder2 = objfolder.Folders("CC")

Dim reg
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.MultiLine = True
reg.Pattern = "SKU:(.*)(?:\r?\n)+数量:(.*)$"

Dim r
r = 1

Range("A:B").Clear

Dim i
For i = objfolder.items.Count To 1 Step -1
Dim item
Set item = objfolder.items(i)

If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.Execute(item.body)

Dim objmatch
For Each objmatch In colmatches
Cells(r, 1) = objmatch.submatches(0)
Cells(r, 2) = objmatch.submatches(1)
r = r + 1
Next

item.Move objfolder2
End If
Next

MsgBox "Done!"

End Sub

下载链接:
链接:https://pan.baidu.com/s/1R2D14QH0VouAeKVl5wuoUA
提取码:tink
milaoshu1020 2019-03-27
  • 打赏
  • 举报
回复
改好了,新的(VBA)代码:

Sub test()
Dim outlook
Set outlook = CreateObject("outlook.application")

Dim ns
Set ns = outlook.getnamespace("MAPI")

Dim objfolder
Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")

Dim objfolder2
Set objfolder2 = objfolder.Folders("CC")

Dim reg
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.MultiLine = True
reg.Pattern = "\r\nSKU:(.*)\r\n数量:(.*)\r\n"

Dim r
r = 1

Dim item
For Each item In objfolder.items
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.Execute(item.body)

Dim objmatch
For Each objmatch In colmatches
Cells(r, 1) = objmatch.submatches(0)
Cells(r, 2) = objmatch.submatches(1)
r = r + 1
Next

item.Move objfolder2
End If
Next

MsgBox "Done!"

End Sub

下载地址:
链接:https://pan.baidu.com/s/1lFKEu0fL_XkcoMcZoV75BQ
提取码:bfhs
卧枝惠中天 2019-03-27
  • 打赏
  • 举报
回复
引用 2 楼 milaoshu1020 的回复:
这个可以用VBS脚本:

Option Explicit

Dim fso
Set fso = createobject("scripting.filesystemobject")

Dim curdir
curdir = fso.getparentfoldername(wscript.scriptfullname)

Dim outlook
set outlook = createobject("outlook.application")

Dim outfile
outfile = fso.buildpath(curdir,"output.csv")

Dim stream
Set stream = fso.opentextfile(outfile,2,True)

Dim ns
set ns = outlook.getnamespace("MAPI")

Dim objfolder
set objfolder = ns.folders("个人文件夹").folders("收件箱").folders("AA").folders("BB")

Dim objfolder2
set objfolder2 = objfolder.folders("CC")

Dim reg
Set reg = createobject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.multiline = True
reg.pattern = "\r\nSKU:(.*)\r\n数量:(.*)\r\n"

Dim item
for each item in objfolder.items
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.execute(item.body)

Dim objmatch
For Each objmatch In colmatches
stream.writeline objmatch.submatches(0) & "," & objmatch.submatches(1)
Next

item.move objfolder2
End If
Next

stream.close
msgbox "Done!"

运行示例:

下载地址:
链接:https://pan.baidu.com/s/1lwb2jVmVLl7OJgrVmGtp8g
提取码:x9dp
不好意思啊,我没说明白,这个如果要写在excel里改怎么写呢?因为我只懂一点点vba,还在自己学习阶段。如果用在excel里面,用sub开头的写法改怎么写呢?我单纯地把你的代码加了个头尾,好像实行不起来,我这个加法应该是错误的!还望大佬多多指教!
milaoshu1020 2019-03-26
  • 打赏
  • 举报
回复
这个可以用VBS脚本:

Option Explicit

Dim fso
Set fso = createobject("scripting.filesystemobject")

Dim curdir
curdir = fso.getparentfoldername(wscript.scriptfullname)

Dim outlook
set outlook = createobject("outlook.application")

Dim outfile
outfile = fso.buildpath(curdir,"output.csv")

Dim stream
Set stream = fso.opentextfile(outfile,2,True)

Dim ns
set ns = outlook.getnamespace("MAPI")

Dim objfolder
set objfolder = ns.folders("个人文件夹").folders("收件箱").folders("AA").folders("BB")

Dim objfolder2
set objfolder2 = objfolder.folders("CC")

Dim reg
Set reg = createobject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.multiline = True
reg.pattern = "\r\nSKU:(.*)\r\n数量:(.*)\r\n"

Dim item
for each item in objfolder.items
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.execute(item.body)

Dim objmatch
For Each objmatch In colmatches
stream.writeline objmatch.submatches(0) & "," & objmatch.submatches(1)
Next

item.move objfolder2
End If
Next

stream.close
msgbox "Done!"

运行示例:

下载地址:
链接:https://pan.baidu.com/s/1lwb2jVmVLl7OJgrVmGtp8g
提取码:x9dp
卧枝惠中天 2019-03-25
  • 打赏
  • 举报
回复
人肉置顶

2,503

社区成员

发帖
与我相关
我的任务
社区描述
VBA(Visual Basic for Applications)是Visual Basic的一种宏语言,是在其桌面应用程序中执行通用的自动化(OLE)任务的编程语言。
社区管理员
  • VBA
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧