Visual Basic, VB6, VB.NET, VB 2005, VB CodeS-SourceS

CodeS-SourceS est hébergé par Frontier.fr

Cliquez ici pour mettre ce site au démarrage de votre navigateur

AccueilCodesTutorielsForumsEmploiLivresGuide achatConnexion

begin process at 2009 07 04 20:29:27

SILVERLIGHT 3 : COMMUNICATION ET MULTICAST par KooKiz

[PERSO] DéCOUVERTES ESTIVALES : LINUX (PART I) par FREMYCOMPANY

[REFACTORING] RESHARPER POUR VISUAL STUDIO 2010 (PREVIEW) par tja

[REFACTORING] ANALYSER VOS EXCEPTIONS AVEC RESHARPER EXCEPTIONAL par tja

SHAREPOINT 2007 : PATTERNS & PRACTICES SHAREPOINT GUIDANCE par phil

RE : INTERDIRE L'ACCèS à UN DOSSIER par PCPT

RE : ENVOYER COMBOBOX.SELECTEDITEM A UNE FUNCTION ET L'ATTRIBUER A UNE TABLE() PROBLEME par PCPT

RE : ENVOYER COMBOBOX.SELECTEDITEM A UNE FUNCTION ET L'ATTRIBUER A UNE TABLE() PROBLEME par CodeIX

INTERDIRE L'ACCèS à UN DOSSIER par beberdu58

INPUT PAST END OF FILE par bbc220229

+ de logiciels à télécharger

1 464 393 membres
293 nouveaux aujourd'hui
15 045 membres club

Trouver une ressource

Trouvez une ressource parmi 40 096 codes, 1 302 858 messages d'aide etc...

Recherche: dans [ Dernières recherches ]

Filtre:Tous les codes.NET uniquementExclure .NET

Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum. Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !

MACRO VB POUR MS OUTLOOK YASSINE ETTARCHEGUE

Information sur la source

Catégorie :VBA Niveau : Expert Date de création : 26/06/2003 Date de mise à jour : 26/06/2003 11:48:03 Vu : 10 953

Auteur : tarchegue

Ecrire un message privé

Note :

6,67 / 10

Commentaire sur cette source (8)

Ajouter un commentaire et/ou une note

Description

Ce macro VB permet de gerer la boite de recption de MS outlook, permet de deplacer les messages selon les pieces attache et vous permet d'automatiser la sauvegarde des pieces attchee

Source

Sub Deleting()
'Procedure du suppression des message de la boite de reception
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myfolder.Items.Count = 0 Then
MsgBox ("le dossier boite de recption est vide")
Else
For i = 1 To myfolder.Items.Count
Set myItem = myfolder.Items(1)
myItem.Delete
Next
End If
End Sub
Sub depot()
'Procedure de traitement des messages
Dim folder As String
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myfolder.Items.Count = 0 Then
MsgBox ("le dossier boite de recption est vide")
Else
For i = 1 To myfolder.Items.Count
Set myItem = myfolder.Items(i)
If myItem.Attachments.Count > 0 Then
Set myAttachments = myItem.Attachments
folder = place(myAttachments.Item(1).DisplayName)
'sauegarde du piece attachee
myAttachments.Item(1).SaveAsFile "C:\Sauvegarde\" & folder & "\" _
& myAttachments.Item(1).DisplayName
Else
Set myNS = myfolder.Folders("Noattach")
End If
'deplacement du message dans les repertoires de MS Outlook
Set myCopiedItem = myItem.Copy
myCopiedItem.Move myNS
Next
End If
End Sub
Function place(folder1 As String)
'foction permattant de detecter a partir du piece attache le repertoire ou on va
' stocker les messages
Select Case folder1
Case "AG01ARJ.ARJ"
place = "Tunis"
Case "AG02ARJ.ARJ"
place = "Sousse"
Case "AG03ARJ.ARJ"
place = "Gafsa"
Case "AG04ARJ.ARJ"
place = "Mednine"
Case "AG05ARJ.ARJ"
place = "Kef"
Case "&VNOMAG.ARJ"
place = "Sfax"
Case "AG07ARJ.ARJ"
place = "Nabeul"
Case "AG08ARJ.ARJ"
place = "Gabes"
Case "AG09ARJ.ARJ"
place = "Monastir"
Case "AG10ARJ.ARJ"
place = "Kairouan"
Case "AG11ARJ.ARJ"
place = "Bizert"
Case "AG12ARJ.ARJ"
place = "Bardo"
Case "AG13ARJ.ARJ"
place = "Benarous"
Case "AG14ARJ.ARJ"
place = "Beja"
Case "AG15ARJ.ARJ"
place = "Kasrine"
Case "AG16ARJ.ARJ"
place = "Sidibouz"
Case "AG17ARJ.ARJ"
place = "kebili"
Case "AG18ARJ.ARJ"
place = "Jendouba"
Case "AG19ARJ.ARJ"
place = "Zaghouan"
Case "AG20ARJ.ARJ"
place = "Siliana"
Case "AG21ARJ.ARJ"
place = "Tozeur"
Case "AG22ARJ.ARJ"
place = "Tataouine"
Case "AG23ARJ.ARJ"
place = "Mahdia"
Case "AG24ARJ.ARJ"
place = "Tunis2"
Case "AG25ARJ.ARJ"
place = "Tunis3"
Case "Sauvegarde.zip"
place = "Depot\Historique"
Case Else
place = "tarch"
End Select
End Function
Sub sauvegarde()
UserForm1.Show
End Sub

Sub Deleting()
'Procedure du suppression des message de la boite de reception
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myfolder.Items.Count = 0 Then
MsgBox ("le dossier boite de recption est vide")
Else
For i = 1 To myfolder.Items.Count
Set myItem = myfolder.Items(1)
myItem.Delete
Next
End If
End Sub

Sub depot()

'Procedure de traitement des messages
Dim folder As String
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myfolder.Items.Count = 0 Then
MsgBox ("le dossier boite de recption est vide")
Else
For i = 1 To myfolder.Items.Count
Set myItem = myfolder.Items(i)
If myItem.Attachments.Count > 0 Then
Set myAttachments = myItem.Attachments
folder = place(myAttachments.Item(1).DisplayName)
'sauegarde du piece attachee
myAttachments.Item(1).SaveAsFile "C:\Sauvegarde\" & folder & "\" _
& myAttachments.Item(1).DisplayName
Else
Set myNS = myfolder.Folders("Noattach")
End If
'deplacement du message dans les repertoires de MS Outlook 
Set myCopiedItem = myItem.Copy
myCopiedItem.Move myNS
Next
End If
End Sub
Function place(folder1 As String)
'foction permattant de detecter a partir du piece attache le repertoire ou on va 
' stocker les messages 
Select Case folder1
Case "AG01ARJ.ARJ"
place = "Tunis"
Case "AG02ARJ.ARJ"
place = "Sousse"
Case "AG03ARJ.ARJ"
place = "Gafsa"
Case "AG04ARJ.ARJ"
place = "Mednine"
Case "AG05ARJ.ARJ"
place = "Kef"
Case "&VNOMAG.ARJ"
place = "Sfax"
Case "AG07ARJ.ARJ"
place = "Nabeul"
Case "AG08ARJ.ARJ"
place = "Gabes"
Case "AG09ARJ.ARJ"
place = "Monastir"
Case "AG10ARJ.ARJ"
place = "Kairouan"
Case "AG11ARJ.ARJ"
place = "Bizert"
Case "AG12ARJ.ARJ"
place = "Bardo"
Case "AG13ARJ.ARJ"
place = "Benarous"
Case "AG14ARJ.ARJ"
place = "Beja"
Case "AG15ARJ.ARJ"
place = "Kasrine"
Case "AG16ARJ.ARJ"
place = "Sidibouz"
Case "AG17ARJ.ARJ"
place = "kebili"
Case "AG18ARJ.ARJ"
place = "Jendouba"
Case "AG19ARJ.ARJ"
place = "Zaghouan"
Case "AG20ARJ.ARJ"
place = "Siliana"
Case "AG21ARJ.ARJ"
place = "Tozeur"
Case "AG22ARJ.ARJ"
place = "Tataouine"
Case "AG23ARJ.ARJ"
place = "Mahdia"
Case "AG24ARJ.ARJ"
place = "Tunis2"
Case "AG25ARJ.ARJ"
place = "Tunis3"
Case "Sauvegarde.zip"
place = "Depot\Historique"
Case Else
place = "tarch"
End Select
End Function
Sub sauvegarde()
UserForm1.Show
End Sub

Conclusion

Faite attention l'execution de ce macro sans vider la boite de reception peut cause des dupplication des messages
avant d'executer ce macro veiller cree des repertoires sous outLook et sur le disque portant ces noms

Sources de la même categorie

EXPORT TABLEAU EXCEL EN BBCODE par nikovb

AFFICHEUR DE LISTE AVEC VALIDATION (EXCEL) par AC045364

REDIMENSIONNER IMAGE par Le Pivert

RENOMMER SÉRIE D'IMAGE DIRECTEMENT AVEC VBA EXCEL (CLASSEMEN... par davidparison

STOCK_MAINTENANCE par awend

Toutes les sources de la catégorie VBA

Commentaires et avis

Commentaire de laestrella le 26/06/2003 12:11:36

T'es dingue il faudrait peu être mettre tout cela dans un zip pour les flemmard comme moi. + facile pour archiver

Commentaire de OLLIVIER le 30/06/2003 11:49:18

le récup vb des pieces jointes m'interrese mais qui est (olFolderInbox) cela bute dessus chez moi merci d'avance pour ton aide

Commentaire de mesmed le 01/07/2003 01:00:08

ya mr yassine 9adech t7ib rou7ek kateb esmik fi esm program

Commentaire de SebOfBorg le 18/08/2003 01:14:22

Bonjour,

2 petites choses,
La premiere, ton source fait appel a un userform1 qui n'est pas dans le source.
Il semble que tu soit en mesure d'enregistrer la piece jointe dans un repertoire mais tu ne le fais pas.
Pour continuer dans les remarques, il est vrai qu'un source zippé est bien meme si c'est un fichier excel, attention quand meme a ne pas mettre de mot de passe...

c'est tres bien quand même

Pour info OLLIVIER, olfolderinbox est Ol ==> Outlook, Folder ==> Dossier, Inbox ==> Reception.
Peut être n'a tu pas réfarencé Outlook dans ton projet !!

A bientôt
Seb Of_Borg

Commentaire de cyretvirg le 18/09/2003 12:48:38

Il s'agit ici d'un VBA, j'aimerais pouvoir faire la même chose en VB6, plus exactement enregistrer tous les mails en fichier txt mais pas ceux de la boite de reception mais d'un dossier de la boite aux lettres. Comment réussir à pointer dans un dossier de la bal ?

Commentaire de cyretvirg le 18/09/2003 12:49:36

Commentaire de patrickdenantes le 22/01/2004 14:21:04

bonjour, merci pour ton code en VBA qui nous permet de visiter la Tunisie!
As-tu une idée pour accéder directement au Folder "Dossiers Personnels"? je n'arrive pas avec :
Set myfolder = myNameSpace.GetDefaultFolder("Dossiers Personnels")

Commentaire de patrut le 09/01/2006 23:39:09

Bonjour,
quelqu'un peut-il me donner un tuyau concernant une macro que j'aimerai réaliser pour:
- ouvrir 1 par 1 tous les fichiers txt d'un dossier (dossier outlook ou dossier de l'explorer)
- faire un email avec chacun d'entre eux en copiant la ligne contenant OBJET et en la mettant en sujet, en mettant tout le texte dans le corps du message

voici ce que j'ai écri mais ça ne fonctionne pas

Sub msg()

'Procedure de traitement des messages
Dim folder As String
Dim MonMsg As Outlook.MailItem
Dim Myitem As Object
Dim MsgTxt As String
Dim txt As String
Dim myFolder As Outlook.MAPIFolder
Dim fs, f


Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts)

If myFolder.Items.Count = 0 Then        'si le dossier Draft est vide, il n'y a pas de msg à envoyer
    MsgBox ("Pas de message dans le dossier Draft")
    Exit Sub
Else
    For i = 1 To myFolder.Items.Count   'pour tous les messages dans le dossier Draft

        ' Ouvrir le fichier attaché
        Const ForReading = 1, ForWriting = 2, ForAppending = 3
        Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
        Set f = fs.GetFile(myFolder.Items(i))
        Set Myitem = f.OpenAsTextStream(ForWriting, TristateUseDefault)

        ' faire un copier de l'ensemble du texte appelé MsgTxt
        myItem.Select.all
        Selection.Copy

        ' faire nouveau message appelé "MonMsg"
        Set MonMsg = olApp.CreateItem(olMailItem)

        ' coller le texte
        MonMsg.Body = txt

        ' chercher le mot OBJET

        ' copier la ligne le contenant

        ' coller le texte dans SUBJECT
        MonMsg.Subject = "  test  "

        ' mettre le destinataire toto
        MonMsg.To = "toto@tata.tutu"

        ' envoyer
        MonMsg.Send
    Next

    ' effacer tous les messages dans le répertoire Draft

    For i = 1 To myFolder.Items.Count
        Set Myitem = myFolder.Items(1)
        Myitem.Delete
    Next
End If
End Sub

merci de votre aide