[VBA-W] Publier sur ExchangeRésolu

Question

ReBonjour à tous (je reposte j'avais oublier le Sujet !! Désolé on est lundi !!)


Le code qui suit permet d'ouvrir la boite de dialogue de publication vers un dossier exchange d'outlook. Je cherche un moyen de préciser le dossier de publication de manière à positionner le focus sur ce dossier. Ou encore d'automatiser la publication sans ouvrir la boite de dialog !


Si vous avez une petite idée !!


Merci


Code :
Public Sub PostExchange()
 
    Dim olApp As Object
    Dim olNS As Object
    Dim oFolder As Object
    Dim oItem As Object
    Dim NomFichier As String
    Dim CheminFichier As String
 
On Error GoTo Fin
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNameSpace("MAPI")
    Set oFolder = olNS.PickFolder
    Set oItem = oFolder.Items.Add("IPM.Document.*.DOC")
    NomFichier = ActiveDocument.Name
    CheminFichier = ActiveDocument.Path
    
    oItem.MessageClass = "IPM.Document.*.DOC"
 
    ' On change le chemin du fichier
    oItem.Attachments.Add CheminFichier & "" & NomFichier
 
    ' On change le thème de notre document
    oItem.Subject = NomFichier
    oItem.Save
Fin:
End Sub

e040098k · Accepted Answer

J'ai trouvé !!!


Après de longue recherche et après avoir réviser mon anglais !!!


Il faut passer par une function par laquelle on retrouve le dernier dossier d'un chemin que l'on à préciser.
J'ai trouvé cette source ici : http://www.outlookcode.com/d/code/getfolder.htm


Voila mon code : 
Code :
Sub PostExchangeAutomatique()
'*************************************************************************
'NECESSITE D'ACTIVER LA REFERENCE "Microsoft Outlook 11.0 object Librairy"
'*************************************************************************
Dim strFolderPath As String
    Dim oFolder As Object
    Dim oItem As Object
    Dim NomFichier As String
    Dim CheminFichier As String
 
On Error GoTo Fin
 
strFolderPath = "Dossiers Publics\Tous les dossiers publics\Archive sesam"
 
    'Appel de la function GetFolder
    Set oFolder = GetFolder(strFolderPath)
    'On à trouver le dernier dossier, c'est dans celui ci que l'on va publier :
    Set oItem = oFolder.Items.Add("IPM.Document.*.DOC")
    NomFichier = ActiveDocument.Name
    CheminFichier = ActiveDocument.Path
    
    oItem.MessageClass = "IPM.Document.*.DOC"
 
    ' On change le chemin du fichier
    oItem.Attachments.Add CheminFichier & "" & NomFichier
 
    ' On change le thème de notre document
    oItem.Subject = NomFichier
    oItem.Save
Fin:
End Sub
 
Public Function GetFolder(strFolderPath As String) As MAPIFolder
'*************************************************************************
'NECESSITE D'ACTIVER LA REFERENCE "Microsoft Outlook 11.0 object Librairy"
'*************************************************************************
  ' le chemin du dossier public doit être de la forme :
  '   "Dossiers publics\Tous les dossiers publics\NomEntreprise\..."
    Dim objApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim colFolders As Outlook.Folders
    Dim objFolder As Outlook.MAPIFolder
    Dim arrFolders() As String
    Dim I As Long
 
   On Error Resume Next
 
   strFolderPath = Replace(strFolderPath, "/", "")
   arrFolders() = Split(strFolderPath, "")
   
   'Instanciation des objets
   Set objApp = CreateObject("Outlook.Application")
   Set objNS = objApp.GetNamespace("MAPI")
   Set objFolder = objNS.Folders.Item(arrFolders(0))
   
   'Si objFolder est non nul alors :
   'On fait une boucle jusqu'a trouver le dernier dossier le l'arborescence
   If Not objFolder Is Nothing Then
     For I = 1 To UBound(arrFolders)
       Set colFolders = objFolder.Folders
       Set objFolder = Nothing
       Set objFolder = colFolders.Item(arrFolders(I))
       If objFolder Is Nothing Then
         Exit For
       End If
     Next
   End If
   
'La function prend la valeur du dossier trouvé :
  Set GetFolder = objFolder
'On libère les objets
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function


Si cela peut servir à quelqu'un d'autre !!


Merci et a bientôt

cs_MPi · Answer

voir ton autre message...

MPi

[VBA-W] Publier sur Exchange

2 réponses

Votre réponse

Discussions similaires