从Outlook 2010中选择基于其主题的邮件，并运行将数据复制到Excel而无需手动干预的宏(Select a message based ont its subject from Outlook 2010, and run a macro that will copy data to Excel without manual intervention)
遗憾的是，我没有VBA的正式背景，但我已经能够从这样的网站中学到很多东西。
问题陈述：
我有一些电子邮件包含需要存储在excel中的信息。 幸运的是，我确实有工作脚本。 没有提供以保持这个更短
我面临的问题是从Microsoft Outlook 2010捕获正确的电子邮件并存储数据而无需手动干预。 电子邮件将包含特定的单词/短语“EVEREST”。 显然它不是唯一收到的电子邮件。 它不包含任何附件，将来自各种发件人。 我已经尝试了各种我在网上找到的宏来从收件箱中提取消息，但是没有一个对我有用。 所以我有一个宏将从个人文件夹中提取消息，该宏然后运行另一个宏来存储电子邮件的内容到excel，然后它将消息移动到其最后的休息位置（另一个个人文件夹）目前他们都工作正常在一起，但需要人工干预才能完成任务。 将邮件移动到个人文件夹后，我只需单击映射到宏的快速访问工具栏图标
为了使消息在个人文件夹上移动，我设置了一个规则来根据单词“EVEREST”移动消息并运行初始脚本。 所有这一切的问题是消息将被移动到文件夹，但需要手动干预才能完成任务。 我希望它能自动运行。
在过去的两个月里，我一直在摸索这一点，似乎陷入了僵局。 非常感谢您的反馈和帮助。
以下是我到目前为止的情况。
我的前景规则集是：
在消息到达主题中的“EVEREST”后应用此规则，并且在此计算机上仅将其移至“EVEREST PRI”文件夹并运行“Project1.ThisOutlookSession.Everest”
' I believe these were put here when I was trying to run ' ' everything via VBA macros, vice using the rule set above ' CLass Module (1) Option Explicit Private WithEvents Items As Outlook.Items Private WithEvents olInboxItems As Items ' ThisOutlookSession contains the following scripts ' 'This is the script that is run from the outlook rules ' ' all it does is calls the "OCF" Sub below ' Sub Everest(email As MailItem) OCF End Sub 'This scipt opens the "EVEREST PRI" personal sub folder' ' and calls the "Prepwork" sub below ' Sub OCF() Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Dim EmailCount As Integer Set objOlApp = CreateObject("Outlook.Application") Set Ns = Session.Application.GetNamespace("MAPI") Set objFolder = Ns.Folders("Personal Folders").Folders("Archives").Folders("EVEREST PRI") Set objOlApp.ActiveExplorer.CurrentFolder = objFolder Set objFolder = Nothing Set objOlApp = Nothing Prepwork End Sub 'I had hoped that the following routine would do the rest of the work ' 'but it doesn't do it all the time. Most the time the message hasn't been ' 'moved to the personal folder before its kicked off. ' 'So I thought I would call another macro to play catch up "Wait" below ' Sub Prepwork() Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Dim EmailCount As Integer Set objOlApp = CreateObject("Outlook.Application") Set Ns = Session.Application.GetNamespace("MAPI") Set objFolder = Ns.Folders("Personal Folders").Folders("Archives").Folders("EVEREST PRI") Set objOlApp.ActiveExplorer.CurrentFolder = objFolder EmailCount = objFolder.Items.count If EmailCount = 1 Then 'MsgBox "A COMSPOT has been recieved, acknowledge to update the chart' ' I tried adding this msgbox to provide some time delay, although ' ' it has worked from time to time, it still requires manual ' ' intervention, which is not desired. ' CopyToExcel ' CopyToExcel is the macro that writes my information to the ' ' Spreadsheet. This script has been flawless and I have created ' ' a Clickable ICON in the Quick Access Toolboar. ' ElseIf EmailCount = 0 Then Wait End If End Sub 'The following "Wait Script was added, hoping to give time for the other ' 'macros to finish, but i suspect they are all linked together, and wont ' 'finish until all macroshave finished including the previously mentioned ' ' "CopyToExcel" macro. ' ' I have also tried to run this macro from the outlook rules, no joy......' Sub Wait() '(email As MailItem) ' this provides a 5 second wait' Sleep (5000) Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Dim EmailCount As Integer Set objOlApp = CreateObject("Outlook.Application") Set Ns = Session.Application.GetNamespace("MAPI") Set objFolder = Ns.Folders("Personal Folders").Folders("Archives").Folders("EVEREST PRI") Set objOlApp.ActiveExplorer.CurrentFolder = objFolder EmailCount = objFolder.Items.count If EmailCount = 1 Then 'MsgBox "A COMSPOT has been recieved, acknowledge to update the chart" CopyToExcel ElseIf EmailCount = 0 Then ' MsgBox "The second Marco (Wait) did not locate a Message in the PRI Folder. Run the script from the Quick Access Toolboar" End If End Sub ' The following macro moves each of the selected items on the screen to an' ' Archive folder. I have not had any problems with this macro ' ' This macro is called from the "CopyToExcel" macro. (not shown as it ' ' has also worked fine since incorporating it ' Sub ArchiveItems() ' Moves each of the selected items on the screen to an Archive folder. Dim olApp As New Outlook.Application Dim olExp As Outlook.Explorer Dim olSel As Outlook.Selection Dim olNameSpace As Outlook.NameSpace Dim olArchive As Outlook.Folder Dim intItem As Integer Set olExp = olApp.ActiveExplorer Set olSel = olExp.Selection Set olNameSpace = olApp.GetNamespace("MAPI") ' This assumes that you have an Inbox subfolder named Archive. Set olArchive = olNameSpace.Folders("Personal Folders").Folders("Archives").Folders("EVEREST Archive") For intItem = 1 To olSel.count olSel.Item(intItem).Move olArchive Next intItem OIB End Sub ' The following macro simply returns the view to the inbox folder, ' ' Thus returning everything to Normal ' ' The Ideal of returning to which every folder, or message was open at ' ' the time the EVEREST message first arrived I thought would be to ' ' complicated, but if any body could solve that... AMAZING.... ' Sub OIB() Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Set objOlApp = CreateObject("Outlook.Application") Set objFolder = Session.GetDefaultFolder(olFolderInbox) Set objOlApp.ActiveExplorer.CurrentFolder = objFolder Set objFolder = Nothing Set objOlApp = Nothing End SubRegretfully I have no formal background in VBA, but I have been able to learn quite a bit from sites like this.
Problem Statement:
I have a few emails with contain information that needs to be stored in excel. Fortunately I do have working script for that. Not provided to keep this somewhat shorter
The problem that I am facing is that capturing the right email from Microsoft Outlook 2010 and storing the data WITHOUT manual intervention. The Email will contain a specific word/phrase, "EVEREST". Obviously it is not the only email received. It contains no attachments, and will come from various senders. I have tried various macros I have found on-line to pull the message from the inbox, but none of them have worked for me. So I have a macros that will pull messages from a personal folder, that macro then runs another macros that stores the contents of the email to excel, then it moves the message to its final resting place (another personal Folder) currently they all work fine together, but require manual intervention to complete the task. After the message is moved to the personal folder I simply click on a Quick Access Toolboar Icon mapped to a macro
To get the message moved over the personal folder i have a rule set up to move the message based on the word "EVEREST" and runs the initial script. The problem with all of this is that the message will get moved to the folder, but needs manual intervention to complete the task. I would like it to run automatically.
I have been fumbling around with this for the past 2 months and seem to be in a stalemate. I would greatly appreciate your feedback and assistance.
The following is what I have so far.
My outlook rule set is:
Apply this rule after the message arrives with "EVEREST" in the subject and on this computer only move it to the "EVEREST PRI" folder and run "Project1.ThisOutlookSession.Everest"
' I believe these were put here when I was trying to run ' ' everything via VBA macros, vice using the rule set above ' CLass Module (1) Option Explicit Private WithEvents Items As Outlook.Items Private WithEvents olInboxItems As Items ' ThisOutlookSession contains the following scripts ' 'This is the script that is run from the outlook rules ' ' all it does is calls the "OCF" Sub below ' Sub Everest(email As MailItem) OCF End Sub 'This scipt opens the "EVEREST PRI" personal sub folder' ' and calls the "Prepwork" sub below ' Sub OCF() Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Dim EmailCount As Integer Set objOlApp = CreateObject("Outlook.Application") Set Ns = Session.Application.GetNamespace("MAPI") Set objFolder = Ns.Folders("Personal Folders").Folders("Archives").Folders("EVEREST PRI") Set objOlApp.ActiveExplorer.CurrentFolder = objFolder Set objFolder = Nothing Set objOlApp = Nothing Prepwork End Sub 'I had hoped that the following routine would do the rest of the work ' 'but it doesn't do it all the time. Most the time the message hasn't been ' 'moved to the personal folder before its kicked off. ' 'So I thought I would call another macro to play catch up "Wait" below ' Sub Prepwork() Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Dim EmailCount As Integer Set objOlApp = CreateObject("Outlook.Application") Set Ns = Session.Application.GetNamespace("MAPI") Set objFolder = Ns.Folders("Personal Folders").Folders("Archives").Folders("EVEREST PRI") Set objOlApp.ActiveExplorer.CurrentFolder = objFolder EmailCount = objFolder.Items.count If EmailCount = 1 Then 'MsgBox "A COMSPOT has been recieved, acknowledge to update the chart' ' I tried adding this msgbox to provide some time delay, although ' ' it has worked from time to time, it still requires manual ' ' intervention, which is not desired. ' CopyToExcel ' CopyToExcel is the macro that writes my information to the ' ' Spreadsheet. This script has been flawless and I have created ' ' a Clickable ICON in the Quick Access Toolboar. ' ElseIf EmailCount = 0 Then Wait End If End Sub 'The following "Wait Script was added, hoping to give time for the other ' 'macros to finish, but i suspect they are all linked together, and wont ' 'finish until all macroshave finished including the previously mentioned ' ' "CopyToExcel" macro. ' ' I have also tried to run this macro from the outlook rules, no joy......' Sub Wait() '(email As MailItem) ' this provides a 5 second wait' Sleep (5000) Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Dim EmailCount As Integer Set objOlApp = CreateObject("Outlook.Application") Set Ns = Session.Application.GetNamespace("MAPI") Set objFolder = Ns.Folders("Personal Folders").Folders("Archives").Folders("EVEREST PRI") Set objOlApp.ActiveExplorer.CurrentFolder = objFolder EmailCount = objFolder.Items.count If EmailCount = 1 Then 'MsgBox "A COMSPOT has been recieved, acknowledge to update the chart" CopyToExcel ElseIf EmailCount = 0 Then ' MsgBox "The second Marco (Wait) did not locate a Message in the PRI Folder. Run the script from the Quick Access Toolboar" End If End Sub ' The following macro moves each of the selected items on the screen to an' ' Archive folder. I have not had any problems with this macro ' ' This macro is called from the "CopyToExcel" macro. (not shown as it ' ' has also worked fine since incorporating it ' Sub ArchiveItems() ' Moves each of the selected items on the screen to an Archive folder. Dim olApp As New Outlook.Application Dim olExp As Outlook.Explorer Dim olSel As Outlook.Selection Dim olNameSpace As Outlook.NameSpace Dim olArchive As Outlook.Folder Dim intItem As Integer Set olExp = olApp.ActiveExplorer Set olSel = olExp.Selection Set olNameSpace = olApp.GetNamespace("MAPI") ' This assumes that you have an Inbox subfolder named Archive. Set olArchive = olNameSpace.Folders("Personal Folders").Folders("Archives").Folders("EVEREST Archive") For intItem = 1 To olSel.count olSel.Item(intItem).Move olArchive Next intItem OIB End Sub ' The following macro simply returns the view to the inbox folder, ' ' Thus returning everything to Normal ' ' The Ideal of returning to which every folder, or message was open at ' ' the time the EVEREST message first arrived I thought would be to ' ' complicated, but if any body could solve that... AMAZING.... ' Sub OIB() Dim objOlApp As Outlook.Application Dim Ns As Outlook.NameSpace Dim objFolder As Outlook.Folder Set objOlApp = CreateObject("Outlook.Application") Set objFolder = Session.GetDefaultFolder(olFolderInbox) Set objOlApp.ActiveExplorer.CurrentFolder = objFolder Set objFolder = Nothing Set objOlApp = Nothing End Sub最满意答案
无需选择，您已经通过规则将所需的“电子邮件”作为参数传递。
运行脚本代码看起来像这样。
Sub Everest(email As MailItem) Dim Ns As NameSpace 'Dim inboxFolder As Folder Dim olArchive As Folder Set Ns = GetNamespace("MAPI") CopyToExcelWithParameter email 'ArchiveItems Set olArchive = Ns.Folders("Personal Folders") Set olArchive = olArchive.Folders("Archives") Set olArchive = olArchive.Folders("EVEREST Archive") email.Move olArchive ' Edit: Just realized this was due to ' unnecessary folder selecting that is now gone ' This is unnecessary now as well 'OIB 'Set inboxFolder = Ns.GetDefaultFolder(olFolderInbox) 'Set ActiveExplorer.CurrentFolder = inboxFolder Set Ns = Nothing Set olArchive = Nothing 'Set inboxFolder = Nothing End Sub您必须重写CopyToExcel才能将电子邮件作为参数
Sub CopyToExcelWithParameter (email as mailitem) ' code that processes "email" directly, not a selection Debug.Print "Do something with " & email.subject End SubThere is no need to select, you already have the required "email" passed as a parameter by the rule.
The run a script code will look something like this.
Sub Everest(email As MailItem) Dim Ns As NameSpace 'Dim inboxFolder As Folder Dim olArchive As Folder Set Ns = GetNamespace("MAPI") CopyToExcelWithParameter email 'ArchiveItems Set olArchive = Ns.Folders("Personal Folders") Set olArchive = olArchive.Folders("Archives") Set olArchive = olArchive.Folders("EVEREST Archive") email.Move olArchive ' Edit: Just realized this was due to ' unnecessary folder selecting that is now gone ' This is unnecessary now as well 'OIB 'Set inboxFolder = Ns.GetDefaultFolder(olFolderInbox) 'Set ActiveExplorer.CurrentFolder = inboxFolder Set Ns = Nothing Set olArchive = Nothing 'Set inboxFolder = Nothing End SubYou will have to rewrite CopyToExcel to take email as a parameter
Sub CopyToExcelWithParameter (email as mailitem) ' code that processes "email" directly, not a selection Debug.Print "Do something with " & email.subject End Sub更多推荐
发布评论