Outlook VBA non exécuté

Question

Je ne suis pas un expert VBA, mais un ami a écrit une macro qui lors de l'envoi d'un e-mail à une personne à partir d'une liste (MoveList) déplacerait automatiquement l'e-mail des éléments envoyés vers un autre dossier.

Jusqu'à aujourd'hui, cela a bien fonctionné - J'ai vérifié les paramètres de macro dans Outlook (modifié pour exécuter toutes les macros) et cela ne fonctionne toujours pas.

Des idées? (Je luttais pour coller la macro, il se plaignait sur le formatage, donc ive uploadés ici)

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@email.com") # 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 

Answer 1

En Février le mois calcule à zéro dans la fonction TwoMonths

Ajouter ceci:

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