运行这个脚本（outlook VBA）放在一个按钮上并让它插入下一行？

Question

几个月来我得到了很多帮助来编写这个脚本。它读取传入的电子邮件，如果主题等于 "Report of Property"，它会读取电子邮件并打开一个文件并插入值。这是正在发生的事情：

它打开文件并将值插入正确的列中。

它没有做什么：

我希望它找到跨页中的第一个空行sheet 并将值粘贴到那里。
我希望它在完成后保存并关闭价差 sheet。
由于我收到的电子邮件数量很多，我想知道如何在按钮上运行执行此操作，而不是让它读取收到的所有电子邮件。示例：我将创建一个规则Outlook 将具有指定主题的所有电子邮件移动到名为 "Maintenance Reports" 的文件夹中。然后，如果可能的话，我会运行该文件夹中的宏，并在当天结束时将所有值放入价差 sheet 中。这很难做到吗？

这是脚本或 VBA 代码：

 Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Dim id As Variant
Dim email As Outlook.MailItem
Dim msgText As Variant

Set xlApp = CreateObject("Excel.Application")


For Each id In Split(EntryIDCollection, ",")

Set email = Application.Session.GetItemFromID(id)

If email.Subject = "Report of Property" Then
Dim line As Variant

    Set xlWB = xlApp.Workbooks.Open(FileName:="C:\Users\George\Desktop\gs.xlsx", AddTOMRU:=False, UpdateLinks:=False)
    Set xlSheet = xlWB.Worksheets(1)
   line = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Offset(1).Row


   For Each line In Split(email.Body, vbCrLf)
        If Left(line, 5) = "Name:" Then
             xlSheet.Range("B6").Value = Trim(Mid(line, 6))
         ElseIf Left(line, 12) = "Time started" Then
             xlSheet.Range("A6").Value = DateValue(Trim(Mid(line, 14)))
          ElseIf Left(line, 8) = "Sage nº:" Then
             xlSheet.Range("D6").Value = Trim(Mid(line, 9))
          ElseIf Left(line, 19) = "Complete Checklist:" Then
             xlSheet.Range("F6").Value = Trim(Mid(line, 20))
         ElseIf Left(line, 4) = "Job:" Then
             xlSheet.Range("G6").Value = Trim(Mid(line, 6))
          ElseIf Left(line, 9) = "Materials" Then
             xlSheet.Range("W6").Value = Trim(Mid(line, 13))
          ElseIf Left(line, 8) = "Duration" Then
             xlSheet.Range("K6").Value = Trim(Mid(line, 12))



         End If
    Next


Else:

End If

xlApp.Visible = True

Next
End Sub

欢迎任何帮助。先感谢您！乔治

Answer 1

您需要检查工作表中的每一行是否有空白值。然后，如果它是空白的，则填充该行。像这样：

Dim blankLine As Long
blankLine = 2 '或者你想从哪里开始
做
如果 xlSheet.Cells(1,1).Value = "" 那么
退出做
结束如果
blankLine = blankLine + 1
循环

然后，您需要在电子表格中填写值的每个语句中使用 blankLine。例如，xlSheet.Cells(2, blankLine).Value = Trim(Mid(line, 6)).

要保存并关闭工作簿，请在工作簿上调用 .Save 和 .Close 方法。例如，xlWB.Save.
在 MSDN 上有很多关于如何将自定义按钮添加到功能区的很好的示例。尝试 https://msdn.microsoft.com/en-us/library/office/ee767705%28v=office.14%29.aspx. Search around. There's lots of tutorials out there. Essentially you'll want to wrap what you currently have inside some code that will let you loop through all the messages in a particular folder. Outlook exposes its object model for that. Check out https://msdn.microsoft.com/en-us/library/office/ee814736%28v=office.14%29.aspx.

祝你好运！

Answer 2

我会尽力回答您问题中与 Outlook 相关的部分：

Because of the number of emails I'm getting, i would like to know how to run this on a button instead of it reading all emails that come in. Example: I would create a rule in Outlook to move all emails with the specified subject to a folder called "Maintenance Reports". Then, If possible, I would run the macro from that folder and get all the values into the spreadsheet at the end on the day. Is this difficult to accomplish?

当然，在 NewMailEx 事件处理程序中创建 Excel 应用程序 class 的新实例并不是正确的想法。

此外，Outlook 不提供任何使用 VBA 自定义 UI 的方法。您需要改为开发 Outlook 加载项。有关详细信息，请参阅 Walkthrough: Creating Your First Application-Level Add-in for Outlook。

您可以使用 Find/FindNext or Restrict 方法在文件夹中查找符合您条件的所有项目。有关详细信息和示例代码，请参阅以下文章：

Answer 3

好吧，尽管评分为负，但我还是按照 Jean-François Corbett 的建议设法让它发挥作用。但说实话，我问这个问题并不是因为我想要一个解决方案。我问这个问题是因为我想要一些指导如何到达那里。这是给任何想尝试的人的答案：

    Option Explicit

    Sub Export()

    Dim xlApp As Excel.Application

    Dim xlWB As Excel.Workbook

    Dim xlSheet As Excel.Worksheet

    Dim id As Variant
    Dim email As Outlook.MailItem
    Dim msgText As Variant
    Set xlApp = CreateObject("Excel.Application")



    Set xlWB = xlApp.Workbooks.Open(FileName:="C:\Users\User\Desktop\gsmaster.xlsm", AddTOMRU:=True, UpdateLinks:=True)

    Set xlSheet = xlWB.Worksheets("LLCHARGES")



    Dim LR As Long

    LR = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row + 1


    Set email = Application.ActiveExplorer().Selection(1)
    If email.Subject = "Report of Property" Then

    Dim line As Variant



    For Each line In Split(email.Body, vbCrLf)


    If Left(line, 4) = "Date" Then
    xlSheet.Range("A" & LR).Value = DateValue(Trim(Mid(line, 6)))
    ElseIf Left(line, 5) = "Name:" Then
    xlSheet.Range("B" & LR).Value = Trim(Mid(line, 6))
    ElseIf Left(line, 8) = "Sage nº:" Then
    xlSheet.Range("D" & LR).Value = Trim(Mid(line, 9))
    ElseIf Left(line, 19) = "Complete Checklist:" Then
    xlSheet.Range("V" & LR).Value = Trim(Mid(line, 20))
    ElseIf Left(line, 4) = "Job:" Then
    xlSheet.Range("G" & LR).Value = Trim(Mid(line, 5))
    ElseIf Left(line, 9) = "Materials" Then
    xlSheet.Range("W" & LR).Value = Trim(Mid(line, 13))
    ElseIf Left(line, 8) = "Duration" Then
    xlSheet.Range("X" & LR).Value = Trim(Mid(line, 12))

    xlWB.Close SaveChanges:=True
    xlApp.Quit
    Set xlApp = Nothing
    Else

    End If



    Next



    Set xlApp = Nothing

    MsgBox ("Exporting Finished!")
    Else
    MsgBox "Not report email!"
    End If

    End Sub

    Sub Issue()
    Dim xlApp2 As Excel.Application

    Dim xlWB2 As Excel.Workbook

    Dim xlSheet2 As Excel.Worksheet

    Dim id As Variant
    Dim email As Outlook.MailItem
    Dim msgText As Variant
    Set xlApp2 = CreateObject("Excel.Application")



    Set xlWB2 = xlApp2.Workbooks.Open(FileName:="C:\Users\User\Desktop\Work.xlsm", AddTOMRU:=True, UpdateLinks:=True)

    Set xlSheet2 = xlWB2.Worksheets("issues")



    Dim LR As Long

    LR = xlSheet2.Range("A" & xlSheet2.Rows.Count).End(xlUp).Row + 1


    Set email = Application.ActiveExplorer().Selection(1)

    Dim line As Variant



    For Each line In Split(email.Body, vbCrLf)



    If Left(line, 12) = "Unrepairable" Then
    MsgBox "Issue found!"
    xlSheet2.Range("C" & LR).Value = Trim(Mid(line, 28))
    ElseIf Left(line, 8) = "Sage nº:" Then
    xlSheet2.Range("A" & LR).Value = Trim(Mid(line, 9))
    ElseIf Left(line, 5) = "Date:" Then
    xlSheet2.Range("D" & LR).Value = DateValue(Trim(Mid(line, 6)))

    Else
    If Left(line, 15) = "No unrepairable" Then
    MsgBox "No Issues found!"
    End If

    End If


    Next
    xlWB2.Close SaveChanges:=True
    xlApp2.Quit
    Set xlApp2 = Nothing
    Beep

    MsgBox "Document has been processed!"
    End Sub

然后我刚刚在功能区上创建了一个按钮，可以依次运行宏。耐心地、反复试验地解决了。

我 post 的答案是为了帮助其他像我一样刚入门并需要一些指导的人。对帮助过的人：谢谢！对于那些没有的人：也谢谢你！对于那些认为每个人都天生聪明，每个人都必须用二进制表达自己以便您可以理解的非常聪明的人，我说：.....!

运行这个脚本（outlook VBA）放在一个按钮上并让它插入下一行？

Run this script (outlook VBA)on a button and get it to insert in the next line?

excel

outlook

vba

运行 这个脚本（outlook VBA）放在一个按钮上并让它插入下一行？

Run this script (outlook VBA)on a button and get it to insert in the next line?

excel

outlook

vba

运行这个脚本（outlook VBA）放在一个按钮上并让它插入下一行？