excel - 将 Outlook 发件箱邮件中的表单字段导出到 Excel

Question

我有一个脚本，它通过过滤器将我的外发邮件导出到 Excel。

现在我喜欢在我的 Excel 中添加一些自定义字段以获取更多信息。我在 Outlook 表单中构建这些字段并在创建新邮件时填写它们。所以我可以为列表添加信息。

有没有办法将它们包含到导出的 excel 表中？我不知道如何定义它们。

形式：

表格说明：

Option Explicit
Public Sub SaveEmailDetails()
 
  Dim AttachCount As Long
  Dim AttachDtl() As String
  Dim ExcelWkBk As Excel.Workbook
  Dim FileName As String
  Dim FolderTgt As MAPIFolder
  Dim HtmlBody As String
  Dim InterestingItem As Boolean
  Dim InxAttach As Long
  Dim InxItemCrnt As Long
  Dim PathName As String
  Dim ReceivedTime As Date
  Dim RowCrnt As Long
  Dim RecipientEmailAddress As String
Dim SenderEmailAddress As String
  Dim SenderName As String
  Dim Subject As String
  Dim TextBody As String
  Dim xlApp As Excel.Application
  Dim objNS As NameSpace

   Dim Item As Object
    Dim varOutput() As Variant
    Dim lngcount As Long
    Dim olNs As Outlook.NameSpace
    Dim olRecip As Outlook.Recipient
    Dim SubFolder As Object
  Dim OrderNr As String
  Dim ProjektNr As String
  PathName = "S:\scan\alexander_"
  FileName = Format(Now(), "yymmdd") & "_OrderList.xlsx"

  ' Open own copy of Excel
  Set xlApp = Application.CreateObject("Excel.Application")
  With xlApp
    ' .Visible = True         ' This slows your macro but helps during debugging
    .ScreenUpdating = False ' Reduces flash and increases speed
    ' Create a new workbook
    ' #### If updating an existing workbook, replace with an
    ' #### Open workbook statement.
    Set ExcelWkBk = xlApp.Workbooks.Add
    With ExcelWkBk
      ' #### None of this code will be useful if you are adding
      ' #### to an existing workbook.  However, it demonstrates a
      ' #### variety of useful statements.
      .Worksheets("Tabelle1").Name = "Gesendete Elemente"    ' Rename first worksheet
      With .Worksheets("Gesendete Elemente")
        ' Create header line
        With .Cells(1, "A")
          .Value = "Bestell Nr.:"
          .Font.Bold = True
        End With
        With .Cells(1, "B")
          .Value = "Lieferant"
          .Font.Bold = True
        End With
          With .Cells(1, "C")
          .Value = "Datum"
          .Font.Bold = True
        End With
         With .Cells(1, "D")
          .Value = "Sender Name"
          .Font.Bold = True
        End With
          With .Cells(1, "E")
          .Value = "Sender EMail Adresse"
          .Font.Bold = True
            End With
          With .Cells(1, "F")
          .Value = "Projekt Nr"
          .Font.Bold = True
        End With
        .Columns("A").ColumnWidth = 18
        .Columns("B").ColumnWidth = 25
           .Columns("C").ColumnWidth = 25
              .Columns("D").ColumnWidth = 25
                 .Columns("E").ColumnWidth = 70
                     .Columns("F").ColumnWidth = 30
      End With
    End With
    RowCrnt = 2
  End With

Set olNs = Application.GetNamespace("MAPI")
    Set olRecip = olNs.CreateRecipient("[e-mail]") '// Owner's Name or email address
    Set FolderTgt = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
    
    Set FolderTgt = FolderTgt.Parent
    
Set FolderTgt = FolderTgt.Folders("Gesendete Elemente")

  For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
    With FolderTgt.Items.Item(InxItemCrnt)
      ' A folder can contain several types of item: mail items, meeting items,
      ' contacts, etc.  I am only interested in mail items.
      If .Class = olMail Then
        ' Save selected properties to variables
        ReceivedTime = .ReceivedTime
        Subject = .Subject
        SenderName = .SenderName
        SenderEmailAddress = .SenderEmailAddress
        RecipientEmailAddress = .To
        OrderNr = Subject
OrderNr = Mid(OrderNr, 16, 8)

        ProjektNr = Subject
ProjektNr = Mid(ProjektNr, 33)

      '  TextBody = .Body
      '  HtmlBody = .HtmlBody
       ' AttachCount = .Attachments.Count
       If AttachCount > 0 Then
          ReDim AttachDtl(1 To 7, 1 To AttachCount)
          For InxAttach = 1 To AttachCount
            ' There are four types of attachment:
            '  *   olByValue       1
            '  *   olByReference   4
            '  *   olEmbeddedItem  5
            '  *   olOLE           6
            Select Case .Attachments(InxAttach).Type
              Case olByValue
            AttachDtl(1, InxAttach) = "Val"
              Case olEmbeddeditem
            AttachDtl(1, InxAttach) = "Ebd"
              Case olByReference
            AttachDtl(1, InxAttach) = "Ref"
              Case olOLE
            AttachDtl(1, InxAttach) = "OLE"
              Case Else
            AttachDtl(1, InxAttach) = "Unk"
            End Select
            Select Case .Attachments(InxAttach).Type
              Case olEmbeddeditem
                AttachDtl(2, InxAttach) = ""
              Case Else
                AttachDtl(2, InxAttach) = .Attachments(InxAttach).PathName
            End Select
            AttachDtl(3, InxAttach) = .Attachments(InxAttach).FileName
            AttachDtl(4, InxAttach) = .Attachments(InxAttach).DisplayName
            AttachDtl(5, InxAttach) = "--"
            On Error Resume Next
            AttachDtl(5, InxAttach) = .Attachments(InxAttach).Parent
            On Error GoTo 0
            AttachDtl(6, InxAttach) = .Attachments(InxAttach).Position
           
            Debug.Assert .Attachments(InxAttach).Class = 5
            AttachDtl(7, InxAttach) = .Attachments(InxAttach).Class
          Next
        End If
        InterestingItem = True
      Else
        InterestingItem = False
      End If
    End With

    If InStr(Subject, "Bestellnummer: ") = 0 Then
     InterestingItem = False
    End If
    'If AttachCount = 0 Then
    '  InterestingItem = False
    'End If
        If InterestingItem Then
      With ExcelWkBk
        With .Worksheets("Gesendete Elemente")
          .Cells(RowCrnt, "A").Value = OrderNr
          .Cells(RowCrnt, "B").Value = RecipientEmailAddress
              With .Cells(RowCrnt, "C")
            .NumberFormat = "@"
            .Value = Format(ReceivedTime, "dd.mm.yyyy")
          End With
          
          .Cells(RowCrnt, "D").Value = SenderName
           .Cells(RowCrnt, "E").Value = SenderEmailAddress
           .Cells(RowCrnt, "F").Value = ProjektNr
              RowCrnt = RowCrnt + 1
          If TextBody <> "" Then
            With .Cells(RowCrnt, "A")
              .Value = "text body"
              .VerticalAlignment = xlTop
            End With
            TextBody = Replace(TextBody, Chr(160), "[NBSP]")
            TextBody = Replace(TextBody, vbCr, "[CR]")
            TextBody = Replace(TextBody, vbLf, "[LF]")
            TextBody = Replace(TextBody, vbTab, "[TB]")
            With .Cells(RowCrnt, "B")
              ' The maximum size of a cell 32,767
              .Value = Mid(TextBody, 1, 32700)
              .WrapText = True
            End With
            RowCrnt = RowCrnt + 1
          End If
        End With
      End With
    End If
  Next
  With xlApp
    With ExcelWkBk
      ' Write new workbook to disc
      If Right(PathName, 1) <> "\" Then
        PathName = PathName & "\"
      End If
      .SaveAs FileName:=PathName & FileName
      .Close
    End With
    .Quit   ' Close our copy of Excel
  End With
  Set xlApp = Nothing       ' Clear reference to Excel
End Sub

标签： excelvbaformsoutlookexport

Answer 1

Option Explicit

Private Sub userDefinedField_FormProjNr_AsText()

    Dim objMailProperty As UserProperty
    Dim objMailItem As MailItem
    Dim PNR As String
        
    Set objMailItem = ActiveExplorer.Selection(1)
    
    Debug.Print
    Debug.Print objMailItem.Subject
    
    Set objMailProperty = objMailItem.UserProperties.add("FormProjNr", olText)
    
    If objMailProperty = "" Then
    
        Debug.Print " First time through this code."
        
        ' simulation of user property being added from a form entry
        objMailProperty.Value = "123456"
        objMailItem.Save
        Debug.Print " FormProjNr updated: " & objMailProperty.Value

    Else
        ' return user property
        PNR = objMailItem.UserProperties("FormProjNr").Value
        Debug.Print " FormProjNr: " & PNR
        
    End If
    
End Sub


Private Sub userDefinedField_Reset()

    Dim objMailProperty As UserProperty
    Dim objMailItem As MailItem
    Dim propName As String
    
    propName = "FormProjNr"
    
    Set objMailItem = ActiveExplorer.Selection(1)
    Debug.Print
    Debug.Print objMailItem.Subject
    
    Set objMailProperty = objMailItem.UserProperties.Find(propName, True)

    If Not objMailProperty Is Nothing Then
        objMailProperty.Delete
        objMailItem.Save
        Debug.Print propName & " deleted."
    End If
    
End Sub