Access 365 VBA проблема с перемещением специфицированного c сообщения Outlook 365 электронной почты в подпапку - PullRequest
Новая
       43

Access 365 VBA проблема с перемещением специфицированного c сообщения Outlook 365 электронной почты в подпапку

1 голос
/ 07 марта 2020

Возникают проблемы с перемещением Outlook, указав c почтовый элемент в подпапку. Я провел время с Outlook MVP на Доступ к VBA-коду, чтобы переместить почтовый элемент Outlook в разные папки, иногда - , чтобы выяснить это.

Только что определили, что Windows 10 Access и Outlook 2019 показывают одинаковое поведение. так что это должно быть в коде ??

Возможно, нужен опытный сотрудник Access, чтобы посмотреть.

Я проверил, что:

Dim Mailobject As Outlook.MailItem Dim myDestFolder Как Outlook.MAPIFolder

непосредственно перед кодом MOVE, я подтвердил, что Mailobject все еще определен и является тем, что мне нужно, распечатав mailobject.subject и mailobject.sender.

Я подтвердил myDestFolder напечатав mydestfolder.name и mydestfolder.folderpath

Обратите внимание, что код работает время от времени, но, конечно, не очень часто.

Я перечислил ниже мой код без обработки, которую я выполняю для каждого сообщения, и скрытие адрес электронной почты: 

Public Sub ReadInbox()
Dim a As Boolean
'''http://www.blueclaw-db.com/read_email_access_outlook.htm
Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset

Dim mynamespace As Outlook.NameSpace
Dim myOlApp As Outlook.Application
On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
    Set myOlApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

Set mynamespace = myOlApp.GetNamespace("MAPI")

Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim Mailobject As Outlook.MailItem
Dim db As DAO.Database
Dim selstr As String
Dim myDestFolder As Outlook.MAPIFolder
Dim myInbox As Outlook.folder

Dim myInbox2 As Outlook.MAPIFolder
    Dim myitems As Outlook.Items
    Dim strFilter As String

    ' let the user choose which account to use
    Set myaccounts = myOlApp.GetNamespace("MAPI").Stores

    For i = 1 To myaccounts.Count

       If myaccounts.Item(i).DisplayName = "volunteerform@?????.org" Then

        Set Items = GetFolderPath("volunteerform@?????.org\inbox").Items

            Set myInbox2 = mynamespace.Folders("volunteerform@?????.org")

            Exit For
        End If
    Next
    If myInbox2 Is Nothing Then
     'If Items Is Nothing Then
        MsgBox ("mailbox not found")
        Exit Sub ' avoid error if no account is chosen
        End If

'
'''''Set InboxItems = myInbox2.Items
Set InboxItems = Items
'
For Each Mailobject In InboxItems

If Mailobject.Subject <> "test" Then GoTo NextMessage

        MsgBox ("found one message")

        '**** do my processing here *****

    On Error GoTo 0

    'Set myDestFolder = GetFolderPath("volunteerform@????.org\inbox\Volunteeremailsprocessed")

    Set myDestFolder = myInbox2.Folders("Inbox")
    Set myDestFolder = myDestFolder.Folders("Volunteeremailsprocessed")
    'Set myDestFolder = myInbox2.Folders("Volunteeremailsprocessed")

     Stop

       Mailobject.Move myDestFolder

NextMessage:
    ' Next email message

    Next Mailobject

'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing

Exit Sub

error_Handling:
Stop
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number

errordescr = Err.Description
MsgBox (errornumber + "  " + errordesc)
Exit Sub

End Sub

Обратите внимание, что я пробовал это в windows 10 с Access 2019 и Outlook 2019 с теми же результатами / той же проблемой.

1 Ответ

1 голос
/ 10 марта 2020

ОК, это код, который работает. Очевидно, он имеет обратную обработку сообщений во входящей почте, чтобы избежать проблем с невозможностью ПЕРЕМЕЩЕНИЯ более чем одного совпадающего сообщения. Однако мой оригинальный кодовый код НЕ ПЕРЕДАЕТ ЛЮБЫХ совпадающих сообщений.

Код, который я использовал в качестве основы для этого решения, взят с веб-сайта, указанного в начале моего кода в качестве комментария. Я благодарен за этот код. 

Public Sub ReadInbox()
''  http://www.vbaexpress.com/forum/showthread.php?58433-VBA-Outlook-Move-mail-shared-Folder-to-shared-subfolder

Dim a As Boolean




'''******Open Outlook if not already open

On Error Resume Next
Set myOlApp = GetObject(, "outlook.Application")
If Err.Number <> 0 Then
    Set myOlApp = CreateObject("Outlook.Application")
    End If

On Error GoTo error_Handling


'''http://www.blueclaw-db.com/read_email_access_outlook.htm
'''On Error GoTo error_Handling

Dim TempRst As DAO.Recordset
Dim TempRst2 As DAO.Recordset
Dim TempRst3 As DAO.Recordset
Dim TempRst4 As DAO.Recordset
Dim rst As DAO.Recordset
Dim mynamespace As Outlook.namespace
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Dim MessageBody As String
Dim selstr As String
Dim myDestFolder As Outlook.folder
Dim myInbox As Outlook.folder
Dim alreadyindb As Boolean
Dim n As Integer

'****

Set mynamespace = myOlApp.getnamespace("MAPI")

Dim NS As namespace

Dim Destinationfolder As folder
Dim myitems As Outlook.items
Dim myInbox2 As folder

Set NS = myOlApp.getnamespace("MAPI")
Set myInbox = NS.Folders("volunteerform@?????.org").Folders("Inbox")
Set myitems = myInbox.items

Set myInbox2 = NS.Folders("volunteerform@?????.org").Folders("inbox")

If myInbox2 Is Nothing Then
    Exit Sub ' avoid error if no account is chosen
    End If

Set myitems = myInbox2.items
'
''''For Each Mailobject In myitems
For n = myitems.Count To 1 Step -1

'''MsgBox ("process mailobject")


If myitems(n).Subject <> "ANV Volunteer Form Submission for Import" Then GoTo NextMessage


'************* all my processing here ********************

NextMessage:

' Next email message

Next n


'''Set OlApp = Nothing
Set myInbox2 = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing

Exit Sub

error_Handling:
Dim errornumber As String
Dim errordescr As String
errornumber = Err.Number
errordescr = Err.Description
a = WriteHistory("Process Form Retrieve_ProcessEmails", "Error = " & errornumber & " Mysection = " & MySection & "  errordescription = " & errordescr & "  MySection=" & MySection)
Exit Sub
End Sub
...