Microsoft 365 VBA sur outlook

lesoldat9

XLDnaute Occasionnel
Bonjour à tous,

J'ai un soucis de références - Projet qui n'est pas disponible.

En effet, la références Microsoft DAO 3.6 Object Library est bien disponible dans les choix mais pas dans le dossier en question
soit C:\Program Files\Common Files\microsoft shared

Le dossier de la référence est pourtant disponible dans le dossier suivant: C:\Program Files (x86)\Common Files\Microsoft Shared

J'ai donc fait un copier coller mais ma macro ne fait pas le lien entre outlook et excel.

Voici mon code:

Sub TT(AGE As String, DAT As String, REFCGT As String, REFESSERS As String, UM As Variant)

Dim XlApp, XlClas
Dim Fichier As String
Utilisateur = Environ("USERNAME")
Fichier = "C:\Users\"& Utilisateur &"\Desktop\Compil Prebooking.xlsm"


'Création d'un Excel
Set XlApp = CreateObject("Excel.Application")
XlApp.DisplayAlerts = False
'Ouverture du classeur
Set XlClas = XlApp.Workbooks.Open(Fichier)

lg = XlClas.Sheets(2).Range("A1").End(xldown).Row + 1
XlClas.Worksheets(2).Range("A" & lg) = AGE
XlClas.Worksheets(2).Range("B" & lg) = DAT
XlClas.Worksheets(2).Range("C" & lg) = REFCGT
XlClas.Worksheets(2).Range("D" & lg) = REFESSERS
For i = 1 To UBound(UM)

test = Trim(Right(UM(i), 4))

If test = "EURO" Then
If i > 1 And XlClas.Worksheets(2).Range("E" & lg) <> "" Then
XlClas.Worksheets(2).Range("E" & lg) = XlClas.Worksheets(2).Range("E" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("E" & lg) = Left(UM(i), 2) * 1
End If
ElseIf test = "PAL" Then
If i > 1 And XlClas.Worksheets(2).Range("F" & lg) <> "" Then
XlClas.Worksheets(2).Range("F" & lg) = XlClas.Worksheets(2).Range("F" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("F" & lg) = Left(UM(i), 2) * 1
End If
ElseIf test = "P6" Then
If i > 1 And XlClas.Worksheets(2).Range("G" & lg) <> "" Then
XlClas.Worksheets(2).Range("G" & lg) = XlClas.Worksheets(2).Range("G" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("G" & lg) = Left(UM(i), 2) * 1
End If
ElseIf test = "QDP" Then
If i > 1 And XlClas.Worksheets(2).Range("H" & lg) <> "" Then
XlClas.Worksheets(2).Range("H" & lg) = XlClas.Worksheets(2).Range("H" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("H" & lg) = Left(UM(i), 2) * 1
End If
ElseIf test = "CIT" Then
If i > 1 And XlClas.Worksheets(2).Range("I" & lg) <> "" Then
XlClas.Worksheets(2).Range("I" & lg) = XlClas.Worksheets(2).Range("I" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("I" & lg) = Left(UM(i), 2) * 1
End If
'*************************************************************************************************************************************

ElseIf test = "CRT" Then
If i > 1 And XlClas.Worksheets(2).Range("J" & lg) <> "" Then
XlClas.Worksheets(2).Range("J" & lg) = XlClas.Worksheets(2).Range("J" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("J" & lg) = Left(UM(i), 2) * 1
End If
'*************************************************************************************************************************************

Else
If i > 1 And XlClas.Worksheets(2).Range("K" & lg) <> "" Then
XlClas.Worksheets(2).Range("K" & lg) = XlClas.Worksheets(2).Range("K" & lg) + (Left(UM(i), 2) * 1)
Else
XlClas.Worksheets(2).Range("K" & lg) = Left(UM(i), 2) * 1
End If
End If
Next i
XlClas.Worksheets(2).Range("L" & lg).FormulaR1C1 = "=RC[-1]+RC[-2]+RC[-3]+RC[-4]+RC[-5]+RC[-6]+RC[-7]"
' XlClas.Worksheets(2).Range("M" & lg).FormulaR1C1 = "=RC[-7]+RC[-6]+RC[-5]/2+RC[-4]/4+RC[-3]*1.25"
XlClas.Worksheets(2).Range("M" & lg).FormulaR1C1 = "=RC[-8]+RC[-7]+RC[-6]/2+RC[-5]/4+RC[-4]*1.25"
'Sauvegarde des modifications et fermeture du classeur
XlClas.Save
XlClas.Close True
'On quitte Excel
XlApp.Quit
'On libère la mémoire des variables
XlApp.DisplayAlerts = True
Set XlClas = Nothing
Set XlApp = Nothing

End Sub

Quelqu'un pour m'aider?
 

lesoldat9

XLDnaute Occasionnel
Vous savez mettre un point d'arret sur une ligne de code?

Pourquoi du VBA Outlook pour traiter un fichier Excel?
Bonjour,

Oui pour le point d'arrêt.
En mettant le stop sur la ligne de code : lg = XlClas.Sheets(2).Range("A1").End(xldown).Row + 1
la macro après le code suivant: Set XlClas = XlApp.Workbooks.Open(Fichier) passe à End sub directement.

vba Outlook pour traiter un fichier excel oui.
Pour faire simple à la réception de mon mail le tableau excel est rempli automatiquement et le mail est supprimé.
 

lesoldat9

XLDnaute Occasionnel
Bonjour,

Elle sort de la macro principale qui fait appel à celle-ci voir ci-dessous:

Public AGE As String, DAT As String, REFCGT As String, REFESSERS As String, UM As String, TabUM As Variant

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'Declaration des variables

Dim arrID() As String
Dim i As Integer, j As Integer
Dim ns_outlook As Outlook.NameSpace
Dim item_outlook As MailItem
Dim itm As Outlook.MailItem
Dim expedtideur As String
Dim object As String
Dim texte As String
Dim TabUM As Variant

On Error Resume Next
Set ns_outlook = Application.Session

'Séparer le matricule de l'objet Outllok
arrID = Split(EntryIDCollection, ",")

'Boucle sur l'objet Outlook
For i = 0 To UBound(arrID)
Set item_outlook = ns_outlook.GetItemFromID(arrID(i))

If item_outlook.Class = olMail Then
Set itm = item_outlook
expediteur = itm.SenderName
object = itm.Subject
texte = itm.Body
If object = "REF Chargement ESSERS/DIVERSEY" Then
AGE = Left(texte, 3)
If AGE <> "GON" And AGE <> "LIL" Then
itm.Delete
Set ns_outlook = Nothing
Set item_outlook = Nothing
Set itm = Nothing
Exit Sub
End If
pos1 = InStr(1, texte, Chr(10)) + 1
DAT = Mid(texte, pos1, 8)
DAT = Right(DAT, 4) & Mid(DAT, 3, 2) & Left(DAT, 2)
pos2 = pos1 + 10
REFCGT = Mid(texte, pos2, 7)
pos3 = pos2 + 9
REFESSERS = Mid(texte, pos3, 10)
pos4 = pos3 + 12
UM = Mid(texte, pos4, 100)
TabUM = Split(UM, "|")
Call TT(AGE, DAT, REFCGT, REFESSERS, TabUM)
itm.Delete
End If
End If
Next i
'Remise à zéro

Set ns_outlook = Nothing
Set item_outlook = Nothing
Set itm = Nothing

End Sub
 

Oneida

XLDnaute Impliqué
Bonjour,

Mettez un point d'arret sur la ligne next i
PAssez le curseur souris sur la variable EntryIDCollection, texte. Si elles ne sont pas vide, passez le curseur sur sur toutes les autres variables y compris celles vous passez en parametre pour
Sub TT(AGE As String, DAT As String, REFCGT As String, REFESSERS As String, UM As Variant)
 

lesoldat9

XLDnaute Occasionnel
Bonjour,

Mettez un point d'arret sur la ligne next i
PAssez le curseur souris sur la variable EntryIDCollection, texte. Si elles ne sont pas vide, passez le curseur sur sur toutes les autres variables y compris celles vous passez en parametre pour
Sub TT(AGE As String, DAT As String, REFCGT As String, REFESSERS As String, UM As Variant)
Je pense avoir compris ou est le problème.
Le bureau du pc est sur Onedrive c'est pour cette raison que ca ne fonctionne plus.
 

Discussions similaires

Réponses
3
Affichages
550
Réponses
4
Affichages
165

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510