將表單字段從 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("edv@example.de") '// 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

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

Answer 2

感謝您的腳本，我試圖將其包含在我的腳本中，但它不起作用

在頂部我添加了這個：

    Dim objMailItem As mailItem
    Dim PNR As String
  Dim objMailProperty As UserProperty

在我定義我的字段的部分中，我添加了這個：

  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)


    Set objMailItem = ActiveExplorer.Selection(1)
 Set objMailProperty = objMailItem.UserProperties.Add("FormProjNr", olText)


        PNR = objMailItem.UserProperties("FormProjNr").Value

當我執行它時，我沒有收到 FormProjNr 歸檔