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

2019-03-24 07:24:21 5k 阅读 AI 写同款 · GEO 优化AI 选题数据监测一键分发 ›

正文提取 java_将Outlook正文提取到Excel VBA 这对你有用 . 我们基本上将电子邮件正文拆分为基于新行的数组 . 请注意，如果电子邮件正文中有空行，则会生成空白单元格 .Public Sub SplitEmail() ' Ensure reference to Word and Excel Object model is setDim rpl As Outlook.MailItemDim itm As ObjectSet itm = GetCu... 阅读详情

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

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

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

这两天多次查资料也没能解决，希望大神指导一下哦~

...全文

Excel技巧：批量给指定收件人发送邮件和指定附件指定收件人和附件发送阅读详情

卧枝惠中天

VBA 2,506 成员 10,830 内容

+ 关注 + 加入社区

切换为时间正序

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

打赏
举报

人肉置顶

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

相关推荐