2017-02-08 5 views
1

Я не эксперт VBA, но друг написал макрос, который при отправке электронной почты человеку из списка (MoveList) автоматически переместит электронное письмо с «Отправленные элементы» в другую папку.Outlook VBA не работает

До сегодняшнего дня это сработало нормально - я проверил параметры макроса в Outlook (изменен для запуска всех макросов), и он все еще не работает.

Любые идеи? (Я изо всех сил, чтобы вставить макрос, он продолжал жаловаться на форматирование, так ив загрузил его здесь)

Option Explicit 
Dim objXL As Object 
Dim objWB As Object 
Dim objWS As Object 
Dim objRange As Object 

Private Function InList(ByVal ToList As String, ByVal DistList As Outlook.DistListItem) As Boolean 
################################################### 
## this function checks if the To list contains # 
## Any of the names in the supplied Distribution # 
## list using a string compare     # 
################################################### 
Dim i As Integer 
Dim test As String 
InList = False 

    For i = 1 To DistList.MemberCount # check if each name is in the to list 
     test = DistList.GetMember(i).Name 
     If InStr(1, ToList, test) Then 
      InList = True  # if name is in the to list then set function to true 
     End If 
    Next i 

End Function 

Private Function TwoMonths() As String 
################################################### 
## this function returns the date 2 months before # 
## today. This does not return the time elelment # 
##            # 
################################################### 

Dim today As String 
Dim day As Integer 
Dim month As Integer 
Dim year As Integer 

today = Now #now returns todays date in the format dd/mm/yyyy hh:mm:ss 

day = Left(today, 2) 
month = Mid(today, 4, 2) 
year = Mid(today, 7, 4) 

If month < 2 Then # checks if 2 months ago is in previous year and corrects for this 
    year = year - 1 
    month = 10 + month 
Else 
    month = month - 2 
End If 

TwoMonths = day & "/" & month & "/" & year 

End Function 

Sub MoveEmails() #(ByVal MoveFrom As String, ByVal MoveTo As String, Distributionlist As String) 

#################################################### 
## This subroutine will move any mail that is sent # 
## any person in the distribution list MoveList in # 
## the last 2 months from the Sent folders   # 
#################################################### 


    Dim DefaultInbox As Outlook.Folder 
    Dim folDefaultSentItems As Outlook.Folder 
    Dim folDestFolder As Outlook.Folder 
    Dim DefaultContacts As Outlook.Folder 
    Dim dlContactList As Outlook.DistListItem 
    Dim TopFolder As Outlook.Folder 
    Dim itSentEmails As Outlook.Items 
    Dim myItem As Object 
    Dim i As Long 
    Dim counter As Integer 
    Dim filterCriteria As String 
    Dim filteredItemsCollection As Outlook.Items 
    Dim Last2Months As String 
    Dim imail 
    Dim mynamespace 

     Set mynamespace = Application.GetNamespace("MAPI") 

     Set DefaultInbox = mynamespace.Folders("my [email protected]") # Change for your primary inbox name 
     Set DefaultContacts = mynamespace.GetDefaultFolder(olFolderContacts) 

     Set folDefaultSentItems = DefaultInbox.Folders("Sent Items") #selects "Sent Items" folder to move from 

     Set TopFolder = mynamespace.Folders("Misc") # Change for your Second inbox name 

     Set folDestFolder = TopFolder.Folders("Sent (Other)") # Set destination folder 

     Set dlContactList = DefaultContacts.Items("MoveList") # Selects the distribution list to use for check 

     Set itSentEmails = folDefaultSentItems.Items  # select all items in "Sent Items" 

     # the next section restricts search to only items sent in the last 2 months 
     # This is to limit the number of emails checked. Assumes that 
     # this macro is run at a frequency less than 2 months 

     Last2Months = TwoMonths 
     filterCriteria = "[ReceivedTime] > """ & Last2Months & " 12:00 AM""" 
     Set filteredItemsCollection = itSentEmails.Restrict(filterCriteria) 

    #loop until all emails are checked 

     i = 1 
     While i <= filteredItemsCollection.Count  
    #loop until all emails are checked 


    # check if it is a mail item 
     If filteredItemsCollection(i).Class = olMail Then 

    # check if to list contains one of the emails in the distribution list 

      If InList(filteredItemsCollection(i).To, dlContactList) Then 

    # If it is in the list move the email to the destination folder 

       filteredItemsCollection(i).Move folDestFolder 

    # Reset the restricted list. When the email list is moved it changes the indexing 
    # in the restricted list so the index loop needs to be decramented and the restriction 
    # list reset. (Error cataching) 

       Set filteredItemsCollection = itSentEmails.Restrict(filterCriteria) 
       i = i - 1 

      End If 

     End If 
     i = i + 1 # incrament index reference 
     Wend 
    End Sub 
+0

Добро пожаловать в StackOverflow! Появляется ли в скрипте какие-либо ошибки? Возможно ли, что региональные настройки (например, формат даты) изменились? – Lyth

+0

Хэши не являются индикаторами комментариев в VBA, поэтому это не будет компилироваться. Что меня немного смущает. В Outlook есть модуль под названием «ThisOutlookSession». Что там? Я предполагаю, что вы использовали событие «ItemSend» для запуска всего этого другого кода, и с ним что-то случилось. –

+0

@Lyth настройки не менялись, все все еще в одном формате (dd/MM/yyyy и h: mm: ss tt – metaljay

ответ

1

В феврале месяце рассчитывает к нулю функции TwoMonths

Добавить это:

If month = 0 Then 
    month = 12 
    year = year - 1 
End If 
+0

В этом макросе уже есть комментарий: Если месяц <2 Затем «проверяет, если 2 месяца назад в прошлом году, и исправления для этого год = год - 1 месяц = ​​10 + месяц – metaljay

+0

спасибо за помощь, он запускается, если я запускаю его через редактор VBA, но в Outlook он все еще не работает, t, если после нажатия отправить – metaljay

+0

У вас должен быть ItemSend-код в ThisOutlookSession, который вызывает MoveEmails. Поместите контрольную точку в MoveEmails в ItemSend и увидите если вы доберетесь до этой линии. – niton