Извлеките свойства Почты, показанные как пустые на военном классифицированном SIPRNet

Я работаю над кодом, который работает в Excel. Код считывает pst-файл в Outlook, просматривает все сообщения электронной почты в целевой папке и помещает тему, дату и время получения, имя отправителя и тело в файл Excel.

Код работает на компьютере под управлением Office 2010 и 2013, который не находится в защищенной сети. Изображение окна Locals ниже показывает запуск в открытой системе.

На компьютере Office 2010 (Windows 7), настроенном в военной засекреченной области, используется SIPRNet (секретная сеть маршрутизатора интернет-протокола), тело и имя отправителя в почтовом элементе пусты для электронной почты, которая имеет оба. В окне Locals также отображаются отсутствующие тело и имя отправителя.

Вот код:

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()

    Dim olApp As Object
    Dim olNs As Object
    Dim oRootFldr As Object ' Root folder to start
    Dim lCalcMode As Long
    Dim olFileName As String
    Dim olFolderName As String
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")

    olFileName = Range("B5")
    olFolderName = Range("B6")

    Set oRootFldr = olNs.Folders(olFileName).Folders(olFolderName)
    Set oWS = ActiveSheet

    lRow = 10
    lCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    GetFromFolder oRootFldr
    Application.ScreenUpdating = True
    Application.Calculation = lCalcMode

    Set oWS = Nothing
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub

Private Sub GetFromFolder(oFldr As Object)

    Dim oItem As Object, oSubFldr As Object

    ' Process all mail items in this folder
    For Each oItem In oFldr.Items
        If TypeName(oItem) = "MailItem" Then
            With oItem 
                oWS.Cells(lRow, 1).Value = .Subject
                oWS.Cells(lRow, 2).Value = .ReceivedTime
                oWS.Cells(lRow, 3).Value = .SenderName
                oWS.Cells(lRow, 4).Value = MailBody(oItem)
                lRow = lRow + 1
            End With
        End If
    Next
    Columns("D:D").WrapText = False

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr
    Next

End Sub


Public Function MailBody(ByVal MailItem As MailItem) As String

    Select Case MailItem.BodyFormat
        Case OlBodyFormat.olFormatPlain, OlBodyFormat.olFormatUnspecified
            MailBody = MailItem.Body
        Case OlBodyFormat.olFormatHTML
            MailBody = MailItem.HtmlBody
        Case OlBodyFormat.olFormatRichText
            MailBody = MailItem.RTFBody
    End Select

End Function

Окно Locals во время запуска в открытой системеОкно локальные во время выполнения

1 ответ