Outlook Problème avec une règle (réglé)

[oceanex]

Bonjour a tous.
Merci d'avance pour votre aide.
Depuis environ 1 semaine je "galère" et je ne comprend pas pourquoi. un deuxième regard va être vraiment apprécié.

mon problème est sur Outlook 2013.
j'utilise une regle qui ensuite déclanche un script
la règle :
Appliquer cette règle après l'arrivée du message
qui contient une pièce jointe
et expediteur est dans le carnet d'adresse "pc"
et sur cet ordinateur uniquement
executer "projet1.script"

voici projet1.script

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub ShellImprime(fichier As String)
        ShellExecute 0, "print", fichier, "", "C:\facture\", 0
End Sub

Sub script(MyMail As MailItem)
   Dim deplacer As String
  deplacer = 0
   
For i = 1 To MyMail.Attachments.Count

    Set fichier = MyMail.Attachments(i)
   
    Repertoire = "C:\facture\"
   
    If Right(UCase(fichier.FileName), 4) = ".PDF" Then
        fichier.SaveAsFile Repertoire & fichier
        ShellImprime (fichier.FileName)
        deplacer = deplacer + 1
    End If
   
    If Right(UCase(fichier.FileName), 4) = ".XLS" Then
        deplacer = -1000
    End If
   
    If Right(UCase(fichier.FileName), 5) = ".XLSX" Then
        deplacer = -1000
    End If
   
    If Right(UCase(fichier.FileName), 4) = ".CSV" Then
        deplacer = -1000
    End If
   
    If i = MyMail.Attachments.Count Then
        If deplacer > 0 Then
   
            Dim myOlApp As Outlook.Application
            Dim myNameSpace As Outlook.NameSpace
            Dim myFolder As Outlook.MAPIFolder
            Dim myFolderArchive As Outlook.MAPIFolder
            Dim myItem As Outlook.MailItem
           
            Set myOlApp = CreateObject("Outlook.Application")
            Set myNameSpace = myOlApp.GetNamespace("MAPI")
            Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
            Set myFolderArchive = myFolder.Folders("fait")
            myFolder.Items(1).Move myFolderArchive
   
        End If
   
    End If

   
    Next i


End Sub

si un fichier excel (xls, xlsx ou csv) est présent il ne doit pas toucher au courriel et le laisser la, mais s'il ne contient que des PDF il doit l'imrpimer et ensuite envoyer dans un dossier "fait".

sa marche a 80% du temps. mais j'ai 20% du temps ou soit il imprime la pièce jointe mais ne la déplace pas, ou bien il traite le courriel meme s'il ne contient pas de pdf (meme aucune piece jointe), il n'imprime rien mais le deplace dans "fait".
j'essaie de comprendre pourquoi et je ne comprends pas.

merci beaucoup pour votre aide,

Oceanex

 

[oceanex]

Bonjour 🙂
j'ai trouvé mon problème
voici mon code si jamais quelqu'un tombe par hasard sur ce problème.

mon code enregistre les pièce jointe (par nom de domaine, ensuite par annee, mois et nomme le fichier avec le jour.
il imprime le fichier.
uniquement lorsqu'il y a un fichier pdf il imprime, et laisse dans la boite de reception les fichiers excel.

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    ' la déclaration pour faire en sorte que sa imprime le PtrSafe permet de faire fonctionne avec une version 64 bit d'outlook, sinon enlever si on est en 32 bit, on peut faire une boucle... mais tier entre toi et moi
    'on est tous en 64 bit

Sub ShellImprime(fichier As String)
        ShellExecute 0, "print", fichier, "", "C:\facture\", 0
End Sub

Sub script(MyMail As MailItem)
  '- : Attachments :  : Attachments/Attachments
  'If MyMail.Attachments.Count > 0 Then
  Dim deplacer As String, mois As String, jour As String, domaine As String, newrepertoire As String, annee As String, savedDomain As String
 

  deplacer = 0
 
 
For i = 1 To MyMail.Attachments.Count

    Set fichier = MyMail.Attachments(i)
   
    repertoire = "H:\AS400RPT\FINANCE\facture\"
   
    If Right(UCase(fichier.FileName), 4) = ".PDF" Then
       
        dateFormat = Format(MyMail.SentOn, "yyyy-mm-dd")
        mois = Format(MyMail.SentOn, "mm")
        jour = Format(MyMail.SentOn, "dd")
        annee = Format(MyMail.SentOn, "YYYY")
       
        savedDomain = Mid(MyMail.SenderEmailAddress, InStrRev(MyMail.SenderEmailAddress, "@") + 1)
       
        newfichier = repertoire & savedDomain & "\" & annee & "\" & mois & "\" & jour & ".PDF"
        newrepertoire = repertoire & savedDomain & "\" & annee & "\" & mois & "\"
       
        If "" = Dir(repertoire & savedDomain, vbDirectory) Then
            MkDir repertoire & savedDomain
        End If
       
        If "" = Dir(repertoire & savedDomain & "\" & annee & "\", vbDirectory) Then
            MkDir repertoire & savedDomain & "\" & annee & "\"
        End If
           
        If "" = Dir(newrepertoire, vbDirectory) Then
            MkDir newrepertoire
        End If
       
        For a = 1 To 1000
       
            If Dir(newfichier) = "" Then

                fichier.SaveAsFile newfichier
                a = 1000
               
            Else
           
               newfichier = repertoire & savedDomain & "\" & annee & "\" & mois & "\" & jour & a & ".PDF"
               
            End If
        Next a
           
            ShellImprime (newfichier)
            deplacer = deplacer + 1
    End If
   
    If Right(UCase(fichier.FileName), 4) = ".XLS" Then
        deplacer = -1000
    End If
   
    If Right(UCase(fichier.FileName), 5) = ".XLSX" Then
        deplacer = -1000
    End If
   
    If Right(UCase(fichier.FileName), 4) = ".CSV" Then
        deplacer = -1000
    End If
   
    If i = MyMail.Attachments.Count Then
        If deplacer > 0 Then
        'On Error Resume Next
            Dim MyNameSpace As Outlook.NameSpace
            Dim MyInbox As Outlook.Folder
            Dim MyDestFolder As Outlook.Folder
            Dim Myitems As Outlook.Items
            Dim Myitem As Object
           
            Set MyNameSpace = Application.GetNamespace("MAPI")
            Set MyInbox = MyNameSpace.GetDefaultFolder(olFolderInbox)
            'Set Myitems = MyMail
            Set MyDestFolder = MyInbox.Folders("Fait")
            MyMail.Move MyDestFolder
                     
   
        End If
   
    End If

   
    Next i


End Sub

j'espère avoir pus aider quelqu'un.

merci et bonne journée
Oceanex