[REF] Wiki 3 de MichelXld (Piloter d'autres applications depuis Excel)

M

MichelXld

XLDnaute Barbatruc
PILOTER D'AUTRES APPLICATIONS DEPUIS EXCEL
Piloter Word, Outlook, Power Point
Les fichiers texte​

​
Les autres applications
  • Trois méthodes pour ouvrir des applications depuis Excel
    Sub lancerPPT()​
    Dim Cible​
    Cible = Shell("POWERPNT.EXE ""C:\Mes documents\flux prod maint compta.ppt""", 1)​
    End Sub​
    Sub openWordV02()​
    thisWorkbook.followHyperlink "C:\Documents and Settings\michel\dossier\general\excel\test.doc"​
    End Sub​
    Sub ouvertureAppli04()​
    Dim Obj As Object​
    Set Obj = createObject("WScript.Shell")​
    Obj.Run "calc.exe ", 1, True'exemple calculatrice​
    End Sub​
    D'autres exemples​
  • Afficher une image avec " l'apercu des images et des telecopies Windows "
  • Fermer une application , Exemple notePad
    Sub fermerUneApplication()​
    'testé avec Excel2002 et WinXP​
    Dim objProcess As Object, colProcessList As Object, objWMIService As Object​
    Dim strComputer As String​
    strComputer = "."​
    Set objWMIService = getObject("winmgmts:" _​
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")​
    Set colProcessList = objWMIService.execQuery _​
    ("Select * from Win32_Process Where Name = 'Notepad.exe'")​
    For Each objProcess In colProcessList​
    objProcess.Terminate​
    Next​
    End Sub​
  • Lire un texte ( utilisation de la librairie Microsoft Speech)
    Il est aussi possible de modifier le ton lors de la diction :​
    en ajoutant à la suite du texte : un espace et 2 points d'exclamations " !!"​
    en ajoutant à la suite du texte : un espace et 2 points d'interrogation " ??"​
  • Lister le nom des fichiers contenus dans un Zip
  • Comment activer une librairie / bibliotheque pour piloter une autre application depuis Excel
    Dans l'éditeur de macros (ALT+F11) :​
    Menu Outils​
    References​
    ​
    Cochez la ligne qui correspond à l'application que vous souhaitez piloter​
    ​
    Cliquez sur OK pour Valider​
    Quelques exemples de librairies disponibles ( en fonction des applications installées sur le poste ) :​
    ​
    Microsoft Word 10.0 Object Library​
    Microsoft ActiveX Data Object 2.x Library ( ADO)​
    Windows Media Player​
    Shockwave Flash​
    Microsoft Outlook 10.0 Object Library​
    …etc…​

    Un exemple pour déclarer une variable en utilisant la bibliotheque Word​
    ​
    Dim wordApp As Word.Application​
    Remarque : L'outil de saisie semi automatique permet d'afficher la bibliotheque Word sans avoir besoin de saisir le nom complet​
    ​
    De la meme maniére, toutes les méthodes et propriétés de la librairie sont accessibles grace à l'outil de saisie semi automatique​
    ​

    Remarque :Vous n'avez pas besoin de réactiver la référence si vous utilisez le classeur sur un autre poste de travail​
    Quand plusieurs versions d'une librairie sont disponibles (exemple AD0 2.0 , 2.1, 2.5 ...) et que vous devez utiliser le classeur sur plusieurs Postes possédant des configurations différentes , sélectionnez la version la plus ancienne commune pour assurer une compatibilité.​
  • Les problemes de comptabilité entre Office 97 et Windows XP
    Les chapitres suivants présentent des exemples pour piloter d'autres applications depuis Excel .​
    Malgré la puissance de ces méthodes , la configuration WindowsXP / Office 97 peut provoquer des erreurs lors de la création d'objets .Le message qui s'affiche est Erreur d'éxecution -2147417851 (80010105)​
    Dans ce cas une solution consiste à remplacer les déclarations de variables de type ,​
    ​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​

    par ,​
    ​
    Dim wordApp As Object​
    Dim wordDoc As Object​

Piloter Word à partir d'Excel
  • Ouvrir un document Word existant à partir d'Excel
    Sub ouvrirDocWordExistant()​
    'necesite d'activer la reference Microsoft Word xx.x Object Library​
    Dim appWrd As Word.Application​
    Dim docWord As Word.Document​
    Set appWrd = createObject("Word.Application")​
    appWrd.Visible = True​
    Set docWord = appWrd.Documents. _​
    Open("C:\mes documents\XLD.doc", readOnly:=True)​
    End Sub​
  • Créer un nouveau document Word à partir d'Excel
    Sub ouvrirNouveauDocWord()​
    'necesite d'activer la reference Microsoft Word xx.x Object Library​
    Dim appWrd As Word.Application​
    Dim docWrd As Word.Document​
    Set appWrd = createObject("Word.Application")​
    appWrd.Visible = True​
    Set docWrd = appWrd.Documents.Add​
    docWrd.saveAs "C:\monDocument.doc"​
    End Sub​
  • Transférer plusieurs tableaux Excel Vers Word , en précisant le nombre de tableaux par page
  • Transferer plusieurs tableaux Excel vers Word puis les redimensionner
  • Exporter un tableau Excel filtré vers Word
  • Compter le nombre de pages d'un document Word
    Sub compterNombrePagesDocWord()​
    Dim wrdApp As Object, wrdDoc As Object​
    Dim nbPage As Byte​
    Dim Ouvrir As String​
    Ouvrir = Application.getOpenFilename("Fichiers Word (*.doc), *.doc")​
    Set wrdApp = createObject("Word.Application")​
    Set wrdDoc = wrdApp.Documents.Open(Ouvrir)​
    wrdDoc.Bookmarks("\endofdoc").Select​
    With wrdDoc​
    nbPage = .builtinDocumentProperties("Number of Pages")​
    msgBox "Il y a " & nbPage & " page(s) dans le document Word : " & Chr(10) & Ouvrir​
    .Close​
    End With​
    wrdApp.Quit​
    Set wrdDoc = Nothing​
    Set wrdApp = Nothing​
    End Sub​
  • Importer la totalité d'un document Word dans une feuille Excel
    Un autre exemple​
    Sub importerWordVersExcel()​
    'necessite d'activer la reference microsoft word 10.0 Object Library​
    Dim docWord As Word.Document​
    Dim appWord As Word.Application​
    Dim Wb As Workbook​
    Set Wb = Workbooks.Add(1)​
    Set appWord = New Word.Application​
    appWord.Visible = False​
    Set docWord = _​
    appWord.Documents.Open("C:\monDocument.doc", readOnly:=True)​
    With appWord​
    .Selection.wholeStory​
    .Selection.Copy​
    End With​
    Wb.activeSheet.Range("A1").Select​
    Wb.activeSheet.Paste​
    appWord.Application.Quit​
    application.cutCopyMode = False​
    Wb.saveAs "C:\copieDocument.xls"​
    End Sub​
  • Importer un tableau Word dans une feuille Excel
  • Exporter une tableau Excel dans Word en appliquant un retrait de mise en page
  • Chercher un mot dans tous les documents Word d'un répertoire
  • Lister les propriétés d'un document Word
  • Insérer , redimensionner et positionner une image dans un document Word existant
  • Coller dans Word une selection de cellules , au format image Bitmap
  • Modifier les marges dans un document Word
  • Remplacer un mot dans un fichier Word
  • Controler si l'application Word est ouverte et la fermer si la réponse est oui ,un deuxieme exemple vérifie si un document spécifique Word est ouvert , et le ferme sans action sur l'application
  • Modifier l'entete ou le pied de page d'un document Word depuis Excel
    Sub enteteEtPiedDePageWord()​
    'necessite d'activer la reference microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Dim Fichier As String​
    Fichier = "C:\Documents and Settings\michel\Doc2.doc" 'adapter le chemin​
    Set wordApp = createObject("Word.Application")​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Open(Fichier)​
    With wordDoc.Sections(1)​
    .Headers(wdHeaderFooterPrimary).Range.Text = "Le titre"​
    .Headers(wdHeaderFooterPrimary).Range.Paragraphs.Alignment = wdAlignParagraphCenter​
    .Footers(wdHeaderFooterPrimary).pageNumbers.Add​
    End With​
    End Sub​
  • Accepter toutes les révisions dans le document Word , sauf les suppressions
    For i = 1 To wordDoc.Revisions.Count​
    If wordDoc.Revisions(i).Type <> wdRevisionDelete Then wordDoc.Revisions(i).Accept​
    Next​
  • Ajouter une colonne dans le tableau d'un document Word
  • Regrouper tous les documents Word d'un répertoire , dans un fichier unique
    Un autre exemple qui permet de compiler les documents d'un repertoire de façon sélective​
  • Boucler sur les graphiques d'un classeur et les coller à l'emplacement de signets , dans un document Word
  • Insérer une image dans la 3eme cellule de la 2eme colonne , d'un tableau word
    Sub insereImageDansCelluleTableauWord()​
    'nécéssite d'activer la référence Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Set wordApp = createObject("word.application") 'ouvrir une session Word​
    Set wordDoc = wordApp.Documents.Open(thisWorkbook.Path & "\leFichier.doc") 'ouvrir un document​
    'insérer une image dans la 3eme Cellule de la 2eme colonne (dans le​
    '1er tableau d'un document Word )​
    wordDoc.Tables(1).Columns(2).Cells(3).Range.inlineShapes.addPicture Filename:= _​
    C:\program files\microsoft office\media\cagcat10\j0149481.wmf, _​
    linkToFile:=False, saveWithDocument:=True​
    With wordDoc.inlineShapes(wordDoc.inlineShapes.Count)​
    .Height = 150 'redimensionne hauteur image​
    .Width = 150 'redimensionne largeur image​
    End With​
    wordApp.Visible = True 'affichier le document Word​
    End Sub​
  • Imprimer un document Word
  • Fusionner des cellules dans un tableau Word
    Sub fusionnerCellsDansTableauWord()​
    'activate Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Set wordApp = createObject("word.application") 'Word Session​
    Set wordDoc = wordApp.Documents.Open("C:\monDocument.doc") 'ouverture Doc​
    wordApp.Visible = True​
    'fusionner les Cells(2,3) à Cells(3,5) dans le premier tableau du document Word​
    wordDoc.Tables(1).Cell(Row:=2, Column:=3).Merge _​
    mergeTo:=wordDoc.Tables(1).Cell(Row:=3, Column:=5)​
    End Sub​
  • Importer les données provenant de plusieurs tableaux Word
    Sub importValuesFromWordTables()​
    'Activer reference Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Dim i As Byte, j As Byte​
    Set wordApp = createObject("word.application")​
    wordApp.Visible = False​
    Set wordDoc = wordApp.Documents.Open(thisWorkbook.Path & "\monFichier.doc")​
    'dans 3 tables Word du document , importer 5 valeurs de la premiere colonne​
    'importer les données de chaque table dans une feuille différente​
    For i = 1 To 3​
    For j = 1 To 5​
    activeWorkbook.Sheets(i).Cells(j, 1) = wordDoc.Tables(i).Columns(1).Cells(j)​
    Next j​
    Next i​
    wordDoc.Close​
    wordApp.Quit​
    End Sub​
  • Copier une ligne precise d'un tableau word et le coller dans Excel
    Sub importValeurs_De_tablesWord()​
    'Activer la reference Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Set wordApp = createObject("word.application")​
    wordApp.Visible = False 'Word reste masqué pendant l'opéraion​
    Set wordDoc = wordApp.Documents.Open("C:\monDocument.doc") 'ouvre le document Word​
    'copies la 3eme ligne de la 1ere table Word​
    wordDoc.Tables(1).Rows(3).Range.Copy​
    'collage dans Excel​
    Range("A1").pasteSpecial xlPasteValues​
    wordDoc.Close 'fermeture document Word​
    wordApp.Quit 'fermeture session Word​
    End Sub​
  • Exporter des donneés excel dans des cellules precises d'un tableau Word
    Sub exportValeursExcelVersTableWord()​
    'Necessite d'activer la reference Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Set wordApp = createObject("word.application")​
    wordApp.Visible = True 'mettre False pour garder Word masqué​
    Set wordDoc = wordApp.Documents.Open("C:\monDocument.doc") 'ouvre le document Word​
    'Tables(2) correspond au 2eme tableu du document Word​
    'transfert la donnée de la cellule A1 dans la 3eme cellule de la 1ere colonne​
    wordDoc.Tables(2).Columns(1).Cells(3).Range.Text = Range("A1")​
    'transfert la donnée de la cellule A2 dans la 2eme cellule de la 3eme colonne​
    wordDoc.Tables(2).Columns(3).Cells(2).Range.Text = Range("A2")​
    'wordDoc.Close True 'ferme le document Word en enregistrant les modifications​
    'wordApp.Quit 'ferme l'application Word​
    End Sub​
  • Vérifier si la premiere cellule d'un tableau est "vide"
    'Chr(13) & Chr(7)sont des caracteres qui apparaissent par defaut dans les cellules lors de la creation du tableau​
    If wordDoc.Tables(1).Columns(1).Cells(1).Range.Text = Chr(13) & Chr(7) Then​
    msgBox "Cellule vide"​
    Else​
    msgBox "Cellule non vide"​
    End If​
  • Exporter des données Excel vers plusieurs signets d'un document Word
  • Afficher des informations sur la version Word installée
    Sub informationsVersionWord()​
    Dim objWord As Object​
    Dim Resultat As String​
    Set objWord = createObject("Word.Application")​
    Resultat = "Version: " & objWord.Version & vbLf & _​
    "Build: " & objWord.Build & vbLf & "Product Code: " & objWord.productCode()​
    msgBox Resultat​
    End Sub​
  • Boucler sur les paragraphes d'un document Word et les supprimer s'ils débutent par le mot "Test"
    Option Compare Text​
    Sub supprimerParagraphe()​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.document​
    Dim cible As Paragraph​
    Set wordApp = New Word.Application​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Open(thisWorkbook.Path & "\Doc1.doc")​
    wordDoc.bookmarks("\startOfDoc").Select​
    For Each cible In wordDoc.Paragraphs​
    cible.Range.Select​
    If Trim(cible.Range.Words(1)) = "Test" Then cible.Range.Delete​
    Next cible​
    End Sub​
    Un autre exemple qui supprime les paragraphes de façon conditionnelle​
    Sub supprimerParagraphes_Conditionnel()​
    'boucle sur les 3 premiers paragraphes du document Word :​
    'si la cellule A1<>1 alors suppression du paragraphe 1​
    'si la cellule A2<>1 alors suppression du paragraphe 2​
    'si la cellule A3<>1 alors suppression du paragraphe 3​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Dim i As Integer​
    Set wordApp = createObject("Word.Application")​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Open("C:\monDocument.doc")​
    For i = 3 To 1 Step -1​
    If Cells(i, 1) <> 1 Then _​
    wordDoc.Paragraphs.Item(i).Range.Delete​
    Next i​
    End Sub​
  • Inserer la date du jour dans un signet Word , nommé "signetDate"
    Sub miseAjourSignetDocWord()​
    'necessite d'activer la reference Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.document​
    Set wordApp = New Word.Application​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Open(thisWorkbook.Path & "\monDocument.doc")​
    wordDoc.Bookmarks("signetDate").Range.Text = Format(Now, "dd/mm/yyyy")​
    End Sub​
  • Remplacer une macro dans tous modèles Word .DOT d'un répertoire ( procédure vba Word )
    Sub remplacement_Macro_wordDot()​
    Dim Debut As Integer, Lignes As Integer, X As Integer​
    Dim Fichier As String, Direction As String​
    Dim Doc As Document​
    Application.screenUpdating = False​
    'boucle sur tous les fichiers .dot du repertoire​
    Direction = "C:\Documents and Settings\michel\dossier\general\excel"​
    Fichier = Dir(Direction & "\*.dot")​
    Do While Fichier <> ""​
    Set Doc = Documents.Open(Direction & "\" & Fichier)​
    'suppression macro nommée "essai" dans module1​
    With Doc.VBProject.VBComponents("Module1").codeModule​
    Debut = .procStartLine("essai", 0)​
    Lignes = .procCountLines("essai", 0)​
    .deleteLines Debut, Lignes​
    End With​
    'ajoute une macro nommée "maNouvelleMacro" dans le Module1​
    With Doc.VBProject.VBComponents("Module1").codeModule​
    X = .countOfLines​
    .insertLines X + 1, "Sub maNouvelleMacro()"​
    .insertLines X + 2, "msgBox ""Coucou"",VBinformation "​
    .insertLines X + 3, "End Sub"​
    End With​
    doEvents​
    Doc.Close True​
    Set Doc = Nothing​
    Fichier = Dir​
    Loop​
    Application.screenUpdating = True​
    End Sub​
  • Récupérer la donnée d'un champ de fusion , dans un document Word ouvert
    Sub recupValeurChampFusion_documentWordOuvert()​
    Dim Appli As Word.Application​
    Dim wordDoc As Word.Document​
    On Error Resume Next​
    Set Appli = getObject(, "Word.Application")​
    Set wordDoc = Appli.Documents("C:\Documents and Settings\michel\leDocument.doc")​
    If wordDoc Is Nothing Then​
    msgBox "Le document est fermé"​
    Else​
    msgBox wordDoc.mailMerge.dataSource.dataFields("leChampX").Value​
    End If​
    End Sub​
  • Transferer un tableau Excel vers Word et l'adapter à la largeur de la page
    Sub envoyerTableauxExcelVersWord_V02()​
    'necessite d'activer la reference Microsoft Word xx.x Object Library​
    Dim docWord As Word.Document​
    Dim appWord As Word.Application​
    Set appWord = New Word.Application​
    appWord.Visible = True​
    Set docWord = appWord.Documents.Add​
    Range("A1:H10").Copy​
    appWord.Selection.Paste​
    docWord.Tables(1).autoFitBehavior wdAutoFitWindow​
    Application.cutCopyMode = False​
    End Sub​
  • Lancer une macro Word depuis Excel
    Sub lancerMacroWord()​
    Dim wordApp As Word.Application​
    Set wordApp = createObject("Word.Application")​
    wordApp.Visible = True​
    wordApp.Documents.Open ("C:\monDocument.doc")​
    wordApp.Run "laMacro"​
    End Sub​
    Un autre exemple si le document Word est deja ouvert​
    Private Sub commandButton1_Click()​
    Dim wordApp As Object​
    Set wordApp = getObject(, "Word.Application")​
    wordApp.Run "maProcedure"​
    End Sub​
  • Passer une information d'Excel dans une Variable Word
    '------------------------​
    'procedure dans Excel​
    'necessite d'activer la reference Microsoft Word xx.x Object Library​
    Private Sub commandButton1_Click()​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Dim monParametreVB As String​
    Set wordApp = createObject("Word.Application")​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Open("C:\monDocument.doc") 'ouverture doc Word​
    monParametreVB = "1234567"​
    'déclenchement de la macro Word​
    'Remarque : la macro Word doit etre placée au niveau de thisDocument​
    wordDoc.laMacro monParametreVB​
    End Sub​
    '------------------------​
    '------------------------​
    'La procédure dans Word à placer au niveau de thisDocument​
    Option Explicit​
    Sub laMacro(maVariableWord As String)​
    thisDocument.Range.Text = maVariableWord​
    End Sub​
    '------------------------​
  • Pour piloter un document Word déjà ouvert , utilisez la fonction getObject :
    Sub piloterUnDocumentWordOuvert()​
    'Activer reference Microsoft Word xx.x Object Library​
    Dim wordDoc As Word.Document​
    Set wordDoc = getObject("C:\monFichier.doc")​
    msgBox wordDoc.paragraphs.Count​
    End Sub​
  • Importer un tableau Word vers Excel en intégrant les retours à la ligne
    Les retours à la ligne dans les cellules d'un tableau Word génèrent autant de cellules supplémentaires lors du collage dans Excel​
    Pour y remédier , cet exemple importe vers Excel le premier tableau du document Word "C:\monFichier.doc" ( qui est déja ouvert) , en conservant le format des cellules​
    Sub importerValeursTableWord_versExcel()​
    Dim wordDoc As Object​
    Dim i As Integer , j As Integer​
    Dim Cible As Variant​
    Set wordDoc = getObject("C:\monFichier.doc")​
    For i = 1 To wordDoc.Tables(1).Rows.Count​
    For j = 1 To wordDoc.Tables(1).Columns.Count​
    Cible = wordDoc.Tables(1).Columns(j).Cells(i)​
    Sheets(1).Cells(i, j) = _​
    Application.worksheetFunction.Substitute(Cible, vbCr, vbLf)​
    Sheets(1).Cells(i, j) = _​
    Left(Sheets(1).Cells(i, j), Len(Sheets(1).Cells(i, j)) - 1)​
    Next j​
    Next i​
    End Sub​
  • Insérer des données dans un champ Word
    'Fields(1) : premier champ du document Word​
    wordDoc.Fields(1).Result.Text = "essai d'ecriture dans champ Word"​
  • Lire les données d'un champ Word
    'Fields(1) : premier champ du document Word​
    msgBox wordDoc.Fields(1).Result.Text​
  • Extraire les phrases / lignes de plusieurs documents Word
    Chaque ligne est importée dans une colonne différente du classeur​
    Lien supprimé​
  • Ouvrir un classeur Excel depuis une macro Word
  • Récupérer l'arborescence des paragraphes d'un document Word
    Chaque paragraphe est supposé débuter par une numérotation​
    Sub boucleParagraphesWord()​
    'necesite d'activer la reference Microsoft Word xx.x Object Library​
    Dim appWrd As Word.Application​
    Dim docWord As Word.Document​
    Dim Paragraphe As Paragraph​
    Dim i As Integer​
    Set appWrd = createObject("Word.Application")​
    appWrd.Visible = True​
    Set docWord = appWrd.Documents.Open("C:\monDocument.doc")​
    For Each Paragraphe In docWord.Paragraphs​
    If Paragraphe.Range.listFormat.listValue <> 0 Then​
    i = i + 1​
    Cells(i, Paragraphe.Range.listFormat.listLevelNumber) = _​
    Paragraphe.Range.listFormat.listString​
    Cells(i, Paragraphe.Range.listFormat.listLevelNumber + 1) = _​
    Paragraphe.Range.Sentences(1).Text​
    End If​
    Next​
    End Sub​
  • Ajouter une checkbox dans la 2eme colonne de toutes les tables d'un document
    'adapté de bbil - developpez.com​
    Dim Tb As Table​
    For Each Tb In docWord.Tables​
    For i = 1 To Tb.Rows.Count​
    Tb.Cell(i, 2).Range.inlineShapes.addOLEControl classType:="Forms.checkBox.1"​
    With docWord.inlineShapes(docWord.inlineShapes.Count).OLEFormat.Object​
    .Caption = ""​
    .Width = 15​
    .Height = 15​
    End With​
    Next i​
    Next Tb​
  • Coller un graphique dans un document Word et insérer du texte en dessous
    Sub collageGraphique_puisAjoutTexte()​
    'nécéssite d'activer la référence Microsoft Word xx.x Object Library​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.Document​
    Set wordApp = createObject("word.application")​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Add​
    Sheets("Feuil1").chartObjects(1).Copy 'copie le graphique​
    'collage graphique​
    wordDoc.Range.pasteSpecial Link:=False, dataType:=wdPasteEnhancedMetafile, _​
    Placement:=wdInLine, displayAsIcon:=False​
    'ajout du texte à la suite du graphique​
    With wordDoc.Content​
    .Collapse Direction:=wdCollapseEnd 'derniere ligne du document​
    .insertBreak Type:=wdLineBreak 'insert saut de ligne​
    .Text = "Le texte à ajouter"​
    End With​
    End Sub​
  • Coller une plage de cellules en pied de page d'un document Word
    With appword.Selection.Sections(1).Footers(wdHeaderFooterPrimary)​
    .Range.Paste​
    .Range.Paragraphs.Alignment = wdAlignParagraphCenter​
    End With​
  • Récupérer la valeur d'un checkbox dans un document Word
    S'il s'agit d'un objet de la boite à outils Controles :​
    msgBox wdDoc.Checkbox2.Value​
    S'il s'agit d'un objet Formulaire :​
    wdDoc.formFields("case a cocher1").Result​
  • Créer un lien hypertexte dans un document Word .
    wordDoc.Range.Hyperlinks.Add Anchor:=wordDoc.Range, Address:="http://www.leSite.com"​
  • Récupérer le texte contenu entre 2 signets .
    Sub recuperationTexteEntreDeuxSignets()​
    Dim wordApp As Word.Application​
    Dim wordDoc As Word.document​
    Dim X As Long, Y As Long​
    Dim Plage As Word.Range​
    Set wordApp = New Word.Application​
    wordApp.Visible = True​
    Set wordDoc = wordApp.Documents.Open("C:\monDocument.doc")​
    X = wordDoc.Bookmarks("Debut").Start​
    Y = wordDoc.Bookmarks("Fin").End​
    Set Plage = wordDoc.Range(Start:=X, End:=Y)​
    Range("A1") = Plage.Text​
    Set wordDoc = Nothing​
    Set wordApp = Nothing​
    End Sub​
  • Lister les raccourcis clavier disponibles dans Word
    Dim appWrd As Object​
    Set appWrd = createObject("Word.Application")​
    appWrd.Visible = True​
    appWrd.listCommands False​
    La meme opération , sans macro dans Word :​
    ​
    Menu Outils​
    Macro​
    Macros​
    Sélectionnez "Commandes Word" dans le menu déroulant "Macros disponibles dans :"​
    Sélectionnez "listerCommandes" dans la liste qui s'affiche​
    Cliquez sur le bouton "Exécuter"​
    Une nouvelle boite de dialogue s'affiche​
    Selectionnez l'option "Configuration actuelle de menu et clavier"​
    Cliquez sur OK pour valider .​

  • Insérer un champ (exemple: numéro de page) dans la cellule d'un tableau placé en pied de page
    Dim appWord As Word.Application​
    Dim docWord As Word.Document​
    Dim Cible As Word.Range​
    Dim x As Integer​
    Set appWord = createObject("word.application")​
    appWord.Visible = True​
    Set docWord = appWord.Documents.Add 'creation doc Word​
    'copie plage de cellule Excel​
    Range("B3:D4").Copy​
    'collage dans le pied de page Word​
    With appWord.Selection.Sections(1).Footers(wdHeaderFooterPrimary)​
    .Range.Paste​
    .Range.Paragraphs.Alignment = wdAlignParagraphCenter​
    End With​
    x = docWord.Sections(1).Footers(wdHeaderFooterPrimary).Range.Tables.Count​
    'le champ va etre inséré dans la 2eme ligne de la 1ere colonne​
    Set Cible = docWord.Sections(1).Footers(wdHeaderFooterPrimary). _​
    Range.Tables(x).Cell(2, 1).Range​
    Cible.Text = ""​
    Cible.Collapse wdCollapseStart​
    'insertion du champ "Numero de page"​
    docWord.Fields.Add Range:=Cible, Type:=wdFieldPage, preserveFormatting:=True​
  • Compter le nombre de fois qu'un mot apparait dans un document
    Set Plage = wordDoc.Content.Words​
    For Each W In Plage​
    If inStr(1, W.Text, "motCible") > 0 Then x = x + 1​
    Next W​
    msgBox x​
  • Sélectionner les x derniers paragraphes d'un document Word
    Dim rngParagraphs As Range​
    Dim x As Integer, Y As Integer​
    ' x = Nombre total de paragraphes dans le document​
    x = activeDocument.Paragraphs.Count​
    ' y = nombre de paragraphes a sélectionner à partir de la fin​
    Y = 5​
    Set rngParagraphs = activeDocument.Range( _​
    Start:=activeDocument.Paragraphs(x - Y).Range.Start, End:=activeDocument.Paragraphs(x).Range.End)​
    rngParagraphs.Select​
Piloter Powerpoint à partir d'Excel

Ce lien n'existe plus​

Utiliser la messagerie Outlook et Outlook Express depuis Excel
  • La différence entre Outlook et Outlook Express.
    Ce lien n'existe plus​
  • Ouvrir le carnet d'adresses Outlook Express
    Private Sub commandButton1_Click()​
    Dim Valeur As Double​
    On Error Resume Next​
    appActivate ("Carnet d'adresse")​
    If Err.Number <> 0 Then​
    Valeur = Shell("C:\Program Files\Outlook Express\wab.exe", 1)​
    End If​
    End Sub​
  • Envoyer la feuille active par mail ( seulement pour Outlook )
    Sub envoiMailEtFeuilleActive()​
    activeSheet.Copy ' créée une copie de la feuille active​
    activeWorkbook.sendMail Recipients:="forumXLD@test.net" 'envoi Mail​
    Application.displayAlerts = False​
    activeWorkbook.Close ' supprime le classeur créé après l'envoi​
    Application.displayAlerts = True​
    End Sub​
  • Envoyer le classeur actif par mail ( seulement pour Outlook )
    Sub envoiMailclasseurActif()​
    Application.dialogs(xlDialogSendMail).Show "forum@xld.fr", "Test d'envoi "​
    End Sub​
  • Envoyer le classeur actif par mail , 2eme méthode
    Sub envoiMailClasseurActifV02()​
    activeWorkbook.sendMail Recipients:="xld@forum.fr"​
    End Sub​
  • N'envoyer que quelques pages d'un classeur par mail
  • Creer et gerer des groupes de diffusion dans Excel
    Lien supprimé​
  • Envoyer un mail avec corps du message multiligne , Outlook Express
    Sub envoiMailOE()​
    Dim Adresse As String​
    Dim Sujet As String, Texte As String​
    Adresse = "forum@XLD.fr"​
    Sujet = "Test d'envoi "​
    Texte = "Bonjour ," & vbCrLf & vbCrLf _​
    & "Ceci est un essai de mail multilignes " & vbCrLf & vbCrLf _​
    & "Signé " & Application.userName​
    Shell "C:\Program Files\Outlook Express\msimn.exe " & "/mailurl:mailto:" _​
    & Adresse & "?subject=" & Sujet & "&Body=" & Texte​
    End Sub​
  • Envoyer un mail avec un lien hypertexte dans le corps du message , Outlook
    une autre méthode​
  • Envoyer un mail avec le chemin d'un répertoire réseau , en lien hypertexte dans le corps du message
  • Envoyer un mail , avec un site http et une adresse mail en lien hypertexte dans le corps du message
    Sub creationMailEtLienHypertexte()​
    Dim olApp As New Outlook.Application​
    Dim olItem As Outlook.mailItem​
    ' necessite d'activer la reference microsoft outlook 10.0 object library​
    Set olItem = olApp.createItem(olMailItem)​
    With olItem​
    .To = "forum@xld.fr"​
    .Subject = "Le titre du message"​
    .Display​
    .Save​
    .send​
    End With​
    Set olItem = Nothing​
    Set olApp = Nothing​
    End Sub​
  • Fermer l'application Outlook Express
    Public Declare Function sendMessage Lib "user32" Alias "sendMessageA" _​
    (byVal HWnd As Long, byVal wMsg As Long, byVal wParam As Long, lParam As Any) As Long​
    Public Declare Function findWindow Lib "user32" Alias "findWindowA" _​
    (byVal lpClassName As String, byVal lpWindowName As String) As Long​
    Sub fermerOutlookExpress()​
    'd'après Chip Pearson, mpep​
    Dim HWnd As Long​
    HWnd = findWindow(vbNullString, "Boîte de réception - Outlook Express")​
    If HWnd > 0 Then sendMessage HWnd, &H10, 0, 0​
    End Sub​
  • Exporter les mails de la boite de réception Outlook , vers des fichiers textes
    Sub transfertMailsDansFichiersTextes()​
    'necessite d'activer la reference Microsoft Outlook xx Object library​
    Dim OLapp As Outlook.Application​
    Dim OLspace As Outlook.nameSpace​
    Dim OLinbox As Outlook.MAPIFolder​
    Dim OLmail As Outlook.mailItem​
    Dim OLbody As String​
    Dim Cible As Integer​
    Dim i As Byte​
    Set OLapp = createObject("Outlook.application")​
    Set OLspace = OLapp.getNamespace("MAPI")​
    Set OLinbox = OLspace.getDefaultFolder(olFolderInbox) 'boite de reception​
    For Each OLmail In OLinbox.Items​
    OLbody = OLmail.Body​
    i = i + 1​
    Cible = freeFile​
    'adapter chemin fichier de suivi sur le reseau​
    Open "C:\Documents and Settings\ " & i & " nomExpediteur Prenom.txt" For Append As #Cible​
    Print #1, Olbody​
    Close #Cible​
    Next​
    Set OLapp = Nothing​
    Set OLspace = Nothing​
    Set OLinbox = Nothing​
    End Sub​
  • Envoyer un mail sans message de confirmation , méthode CDO
  • Envoyer un mail avec texte multiligne et sans message de confirmation , méthode CDO
    Lien supprimé​
  • Envoyer un mail en automatique en utilisant le contenu d'un fichier texte comme corps du message
  • Envoyer un mail avec une demande de confirmation de réception et de lecture
    Sub mail_confirmationReception_Lecture()​
    'necessite d'activer la reference Microsoft Outlook xx.x Object Library​
    Dim Ol As New Outlook.Application​
    Dim olMail As mailItem​
    Set Ol = New Outlook.Application​
    Set olMail = Ol.createItem(olMailItem)​
    With olMail​
    .Subject = "Le sujet traité "​
    .Body = "Bonjour , " & vbLf & "Vous trouverez ci joint..."​
    .Attachments.Add "C:\Documents and Settings\michel\dossier\general\excel\monFichier.txt"​
    '.deferredDeliveryTime = Date + 2 + #5:00:00 AM# 'option pour envoi différé du message​
    .originatorDeliveryReportRequested = True 'confirmation de réception​
    .readReceiptRequested = True 'confirmation de lecture​
    .Send​
    End With​
    End Sub​
  • Vérifier si Outlook est ouvert
    Si Outlook est ouvert l'application devient la fenêtre active​
    Si Outlook est fermé la macro va ouvrir l'application​
  • Compter le nombre de messages , total et non lus , dans la boite de réception
    Sub compterMessagesBoiteReception()​
    'necessite d'activer la reference Microsoft Outlook xx.x Object Library​
    Dim OLapp As Outlook.Application​
    Dim OLspace As Outlook.Namespace​
    Dim OLinbox As Outlook.MAPIFolder​
    Set OLapp = Createobject("Outlook.application")​
    Set OLspace = OLapp.Getnamespace("MAPI")​
    Set OLinbox = OLspace.getDefaultFolder(olFolderInbox)​
    Msgbox "Nombre de messages total dans la boite de reception : " & OLinbox.Items.Count​
    Msgbox "Nombre de messages non lus : " & OLinbox.unReadItemCount​
    End Sub​
    Un autre exemple pour boucler sur tous les dossiers de la boite de reception et compter le nombre de mails​
    Sub boucleDossiersBoiteDeReception()​
    Dim Ol As New Outlook.Application​
    Dim Ns As Outlook.nameSpace​
    Dim Dossier As Outlook.MAPIFolder​
    Set Ns = Ol.getNamespace("MAPI")​
    Set Dossier = Ns.getDefaultFolder(olFolderInbox)​
    Debug.Print Dossier.Name & " --> " & Dossier.Items.Count​
    boucleDossiers Dossier, ""​
    End Sub​
    Private Sub boucleDossiers(byVal Fld As Outlook.MAPIFolder, nomDossier As String)​
    Dim i As Integer​
    Dim Dossier1 As Outlook.MAPIFolder​
    Dim OLmail As Outlook.mailItem​
    If Fld.Folders.Count > 0 Then​
    Do Until i = Fld.Folders.Count​
    i = i + 1​
    Set Dossier1 = Fld.Folders(i)​
    Debug.Print Dossier1.Name & " --> " & Dossier1.Items.Count​
    If Dossier1.Folders.Count > 0 Then boucleDossiers Dossier1, nomDossier​
    Loop​
    End If​
    End Sub​
  • Gérer le calendrier Outlook : Lister, Creer, Modifier et Supprimer des rendez vous
    Lien supprimé​
    Lien supprimé​
  • Créer des rendez vous en masse , à partir d'un tableau Excel
    Lien supprimé​
  • Créer un nouveau dossier dans la boite de réception Outlook
    Sub creationDossierDansBoiteReception()​
    Dim olApp As New Outlook.Application​
    Dim olSpace As Outlook.nameSpace​
    Dim olFolder As Outlook.MAPIFolder​
    Dim olInbox As Outlook.MAPIFolder​
    Set olSpace = olApp.getNamespace("MAPI")​
    Set olInbox = olSpace.getDefaultFolder(olFolderInbox)​
    Set olFolder = olInbox.Folders.Add("nouveau dossier" & Format(Date, "yymmdd"))​
    End Sub​
  • Insérer une plage de cellules au format tableau , dans le corps d'un message Outlook
  • Une autres solution pour insérer une plage de cellules dans le corps d'un message ,Excel2002
    (utilisation de la fonction intégrée dans Excel2002 )​
    Sub envoiPlageCellules_Excel2002()​
    Activesheet.Range("A1:B5").Select ' la plage de cellules à envoyer​
    Activeworkbook.Envelopevisible = True​
    With Activesheet.Mailenvelope​
    .Introduction = "bonjour , ci joint les données ..."​
    .Item.To = "leForum@xld.fr"​
    .Item.Subject = "le sujet"​
    .Item.Send​
    End With​
    End Sub​
  • Trier les messages dans la boite de réception Outlook
    'La macro créée un nouveau dossier dans la boite de reception et y transfert les messages reçus ,si l'émetteur n'existe pas dans la liste de vos "Contacts"​
    Sub triMessages_dansBoiteReception()​
    'nécéssite d'activer la référence Microsoft Outlook 10.0 Object Library​
    Dim olApp As New Outlook.Application​
    Dim olSpace As Outlook.nameSpace​
    Dim olFolder As Outlook.MAPIFolder, olInbox As Outlook.MAPIFolder​
    Dim Adresse As Outlook.addressList​
    Dim i As Integer, j As Integer​
    Dim leContact As Boolean​
    On Error goTo Fin​
    Set olSpace = olApp.getNamespace("MAPI")​
    Set olInbox = olSpace.getDefaultFolder(olFolderInbox)​
    Set olFolder = olInbox.Folders.Add("Nouveau Répertoire " & Format(Date, "yyyymmdd"))​
    Set Adresse = olSpace.addressLists("Contacts")​
    On Error goTo 0​
    '################################################################​
    ''! normalement le nouveau dossier doit etre créé sans volet de prévisualisation​
    olApp.activeExplorer.currentView = "Messages"​
    '################################################################​
    For j = olInbox.Items.Count To 1 Step -1​
    leContact = False​
    For i = 1 To Adresse.addressEntries.Count​
    If olInbox.Items.Item(j).senderName = Adresse.addressEntries.Item(i) Then _​
    leContact = True: Exit For​
    Next i​
    If leContact = False Then olInbox.Items.Item(j).Move olFolder​
    Next j​
    'msgBox olFolder.Items.Count & " messages non identifiés ont été tranférés dans " & _​
    "le dossier Outlook : Nouveau Répertoire " & Format(Date, "yyyymmdd"), , "Message"​
    Exit Sub​
    Fin:​
    msgBox "Opération annulée : le nouveau répertoire spécifié existe déja .", , "Message"​
    End Sub​
  • Trier les messages automatiquement dès leur reception
    ( macro outlook : voir le message du 28/04/2005 18:36 )​
  • Les evenements dans Outlook : Lancer une macro Excel depuis Outlook , lors de l'envoi d'un message .
    Lien supprimé​
    Accédez à l'éditeur de macros Outlook (Alt+F11)​
    Cliquez sur thisOutlookSession dans l'explorateur de projet​
    En haut de l'éditeur , remplacez "General" par "Application" (menu deroulant)​
    Dans le menu déroulant de droite , s'affiche la liste des evenements associés :​
    ​
    Private Sub Application_advancedSearchComplete(byVal searchObject As Search)​
    Private Sub Application_advancedSearchStopped(byVal searchObject As Search)​
    Private Sub Application_itemSend(byVal Item As Object, Cancel As Boolean)​
    Private Sub Application_MAPILogonComplete()​
    Private Sub Application_newMail()​
    Private Sub Application_optionsPagesAdd(byVal Pages As propertyPages)​
    Private Sub Application_Quit()​
    Private Sub Application_Reminder(byVal Item As Object)​
    Private Sub Application_Startup()​

    La procédure evenementielle Outlook ci dessous , déclenche la macro Excel "maProcedure" au moment de l'envoi d'un Mail , si le sujet du message est "Test"​
    Dans cet exemple il existe préalablement un classeur Excel ouvert contenant une macro nommée "maProcedure"​
    Private Sub Application_itemSend(byVal Item As Object, Cancel As Boolean)​
    Dim excelApp As Object​
    Set excelApp = getObject(, "Excel.Application")​
    If Item = "Test" Then excelApp.Run "maProcedure"​
    End Sub​
  • Ajouter un contact dans Outlook
    Sub ajouterContactOutlook()​
    'necessite d'activer la reference Microsoft Outlook xx.x Object Library​
    Dim objOutlook As New Outlook.Application​
    Dim objContact As contactItem​
    Set objContact = objOutlook.createItem(olContactItem)​
    With objContact​
    .email1Address = "michelxld@yahoo.com"​
    .firstName = "michel"​
    .lastName = "xld"​
    .homeTelephoneNumber = "00 00 00 00 00"​
    .homeAddressCity = "XLDcity"​
    .Save​
    End With​
    End Sub​
  • Vérifier si un nom (xld) existe dans la liste des contacts Outlook
    Sub controleLastName_contactsOutlook()​
    Dim olApp As New Outlook.Application​
    Dim Cible As Outlook.contactItem​
    Dim dossierContacts As Outlook.MAPIFolder​
    Set olApp = New Outlook.Application​
    Set dossierContacts = olApp.getNamespace("MAPI").getDefaultFolder(olFolderContacts)​
    Set Cible = dossierContacts.Items.Find("?[lastName] = ""xld""")​
    If Not Cible Is Nothing Then​
    msgBox "Le contact existe"​
    Else​
    msgBox "Le contact n'existe pas"​
    End If​
    End Sub​
    Un autre exemple qui utilise une variable pour définir la donnée à rechercher :​
    Dans ce cas la variable doit etre encadrée par des apostrophes "'"​
    Cet exemple vérifie si une adresse mail existe dans la liste des contacts :​
    Dim leMail As String​
    leMail = "nom.Prenom@mail.fr"​
    Set Cible = dossierContacts.Items.Find("?[email1Address] = '" & leMail & "'")​
  • Extraire les numéros de téléphone dans la liste des contacts Outlook
    Sub numeroTelephone_contactsOutlook()​
    Dim olApp As New Outlook.Application​
    Dim Cible As Outlook.contactItem​
    Dim dossierContacts As Outlook.MAPIFolder​
    Dim Resultat As String​
    Set olApp = New Outlook.Application​
    Set dossierContacts = olApp.getNamespace("MAPI").getDefaultFolder(olFolderContacts)​
    For Each Cible In dossierContacts.Items​
    Resultat = Resultat & Cible.homeTelephoneNumber & vbTab & Cible.lastNameAndFirstName & vbLf​
    Next​
    msgBox Resultat, , "Liste des numeros de telephone Outlook-Contacts"​
    End Sub​
  • Boucler sur tous les dossiers personnels Outlook pour extraire les messages reçus d'un expediteur précis
    La boite de réception , la boite des éléments supprimés et tous leurs sous dossiers sont pris en compte​
  • Afficher le calendrier outlook
    Sub afficherCalendrierOutlook()​
    Dim outApp As Outlook.Application​
    Dim outObj As nameSpace​
    Set outApp = createObject("Outlook.Application")​
    Set outObj = outApp.getNamespace("MAPI")​
    Set outApp.activeExplorer.currentFolder = _​
    outObj.getDefaultFolder(olFolderCalendar)​
    outApp.activeExplorer.Display​
    End Sub​
  • Ajouter une tache à un destinataire en réseau
  • Lister les taches Outlook .
    Dim olApp As Outlook.Application​
    Dim olNs As nameSpace​
    Dim Fldr As MAPIFolder​
    Dim olTsk As taskItem​
    Set olApp = New Outlook.Application​
    Set olNs = olApp.getNamespace("MAPI")​
    Set Fldr = olNs.getDefaultFolder(olFolderTasks)​
    For Each olTsk In Fldr.Items​
    Debug.Print olTsk.Subject & " - " & olTsk.startDate & " - " & olTsk.Status​
    Next olTsk​
    Set olTsk = Nothing​
    Set Fldr = Nothing​
    Set olNs = Nothing​
    Set olApp = Nothing​
  • Insérer une image dans le corps d'un message Outlook
    Ce lien n'existe plus​
  • Envoyer une page HTML dans le corps d'un message Outlook
    Sub envoiPageHTML_corpsMessageOutlook()​
    'Necessite d'Activer la reference Microsoft Outlook xx.x Object Library​
    Dim olApp As New Outlook.Application​
    Dim olItem As Outlook.mailItem​
    Dim S As String​
    'necessite d'Activer la reference Microsoft Internet Controls​
    Dim IE As internetExplorer​
    Set IE = createObject("internetExplorer.Application")​
    With IE​
    .Visible = False​
    Do Until .readyState = READYSTATE_COMPLETE​
    doEvents​
    Loop 'attend la fin du chargement​
    End With​
    S = IE.document.documentElement.innerHTML​
    doEvents​
    IE.Quit​
    Set IE = Nothing​
    Set olItem = olApp.createItem(olMailItem)​
    With olItem​
    .Subject = "le titre"​
    .HTMLBody = S​
    .Display​
    .Save​
    .Send​
    End With​
    End Sub​
  • Envoyer un mail automatique , avec notification de réception du destinataire
    Sub envoiMail_avecNotification()​
    'testé avec WinXP & Excel2002​
    Dim iMsg As Object, iConf As Object​
    Set iMsg = createObject("CDO.Message")​
    Set iConf = createObject("CDO.Configuration")​
    With iMsg​
    Set .Configuration = iConf​
    .To = "leForum@xld.fr" 'renvoie une erreur si l'adresse est non valide​
    .Subject = "Le titre du message"​
    .HTMLBody = "Ceci est un essai ..."​
    .Fields("urn:schemas:mailheader:disposition-notification-to") = "expediteur@monMail.fr"​
    .Fields("urn:schemas:mailheader:return-receipt-to") = "expediteur@monMail.fr"​
    .Fields.Update​
    .Send​
    End With​
    Remarque : consultez ce lien si vous avez un probleme avec la méthode .Send​
    Lien supprimé​
  • Supprimer les contacts qui appartiennent à une catégorie spécifique ( exemple catégorie "Amis" )
    Sub supprimerContacts_Filtre_Categorie()​
    Dim olApp As New Outlook.Application​
    Dim Cible As Outlook.contactItem​
    Dim dossierContacts As Outlook.MAPIFolder​
    Set olApp = New Outlook.Application​
    Set dossierContacts = olApp.getNamespace("MAPI").getDefaultFolder(olFolderContacts)​
    For Each Cible In dossierContacts.Items​
    If Cible.Categories = "Amis" Then Cible.Delete​
    Next​
    End Sub​
Envoyer un mail différé d'une heure

Sub mail_envoiDiffere()​
'necessite d'activer la reference Microsoft Outlook xx.x Object Library​
Dim Ol As Outlook.Application​
Dim olMail As mailItem​
Set Ol = New Outlook.Application​
Set olMail = Ol.createItem(olMailItem)​
With olMail​
.To = "leForum@xld.fr"​
.Subject = "Le sujet traité "​
.Body = "Bonjour , " & vbLf & "Vous trouverez ci joint..."​
'------------------------​
'option pour envoi différé d'une heure​
.deferredDeliveryTime = Date + Time + (1 / 24)​
'------------------------​
.Send​
End With​
End Sub​

  • Controler si un champ personnalisé nommé "myCustomField" Existe dans les contacts Outlook
    Si le champ n'existe pas , la procédure va le créer et y insérer des données "My data"​
    Sub Control_Add_userProperty_contactsOutlook()​
    'Necessite d'activer la reference Microsoft Outlook xx.x Object Library​
    Dim olApp As New Outlook.Application​
    Dim Cible As Outlook.contactItem​
    Dim dossierContacts As Outlook.MAPIFolder​
    Dim myProp As Outlook.userProperty​
    Set olApp = New Outlook.Application​
    Set dossierContacts = olApp.getNamespace("MAPI").getDefaultFolder(olFolderContacts)​
    For Each Cible In dossierContacts.Items​
    Set myProp = Cible.userProperties("myCustomField")​
    If myProp Is Nothing Then​
    Set myProp = Cible.userProperties.Add("myCustomField", olText)​
    myProp.Value = "My data"​
    Cible.Save​
    End If​
    Next​
    End Sub​
  • Envoyer un message Outlook pour multi destinataires
    Sub envoiMesssage_multiDestinataires()​
    Dim outApp As New Outlook.Application​
    Dim Dest As Outlook.Recipient​
    Dim Msg As Outlook.mailItem​
    Set Msg = outApp.createItem(0)​
    Msg.Subject = "le sujet"​
    Msg.Body = "bonjour, " & vbLf & "vous trouverez ci joint ... "​
    Msg.Display​
    Set Dest = Msg.Recipients.Add("destinataire1@mail.com")​
    Set Dest = Msg.Recipients.Add("destinataire2@provider.com")​
    Set Dest = Msg.Recipients.Add("Prenom1 Nom1") 'fonctionne seulement si present dans la liste des contacts​
    Msg.Send​
    End Sub​
  • Créer une liste de distribution et y insérer quelques adresses mail
    Sub creationListeDistribution()​
    Dim outApp As Outlook.Application​
    Dim DL As distListItem​
    Dim oItem As mailItem​
    Dim oRecipients As Recipients​
    Set outApp = createObject("Outlook.Application")​
    Set DL = outApp.createItem(olDistributionListItem)​
    DL.DLName = "Ma nouvelle liste"​
    Set oItem = outApp.createItem(olMailItem)​
    Set oRecipients = oItem.Recipients​
    oRecipients.Add "contact1@mail.fr"​
    oRecipients.Add "contact2@mail.fr"​
    oRecipients.resolveAll​
    DL.addMembers oRecipients​
    DL.Save​
    End Sub​
  • Exporter les pieces jointes contenues dans les messages de la boite de réception
    Sub exportPiecesJointes_boiteReception()​
    Dim outlookApp As New Outlook.Application​
    Dim olSpace As Outlook.nameSpace​
    Dim olInbox As Outlook.MAPIFolder​
    Dim pceJointe As Outlook.Attachment​
    Dim j As Integer, i As Integer, x As Integer​
    Set outlookApp = createObject("Outlook.Application")​
    Set olSpace = outlookApp.getNamespace("MAPI")​
    Set olInbox = olSpace.getDefaultFolder(olFolderInbox)​
    For j = 1 To olInbox.Items.Count 'boucle sur tous les messages de la boite de réception​
    If Not olInbox.Items.Item(j).Attachments.Count = 0 Then​
    For i = 1 To olInbox.Items.Item(j).Attachments.Count​
    Set pceJointe = olInbox.Items.Item(j).Attachments(i)​
    If pceJointe.Filename = "CG Card V2.zip" Then 'recuperer uniquement les fichiers nommés CG Card V2.zip​
    x = x + 1​
    pceJointe.saveAsFile "C:\Documents and Settings\" & x & "_" & pceJointe​
    End If​
    Set pceJointe = Nothing​
    Next i​
    End If​
    Next j​
    End Sub​
  • Activer la référence Outlook sous Office97 (Une astuce donnée par Charly) .
    Si vous ne trouvez pas "Microsoft Outlook 8.0 Object library" dans la liste des références VBAProject , activez "Modèle d'objet Microsoft Outlook 8.0"​
Trier les messages de la boite de réception sur la date de réception

Dim OLapp As Outlook.Application​
Dim OLspace As Outlook.nameSpace​
Dim OLinbox As Outlook.MAPIFolder​
Dim oMt As Outlook.mailItem​
Dim oItem As Outlook.Items​
Set OLapp = createObject("Outlook.application")​
Set OLspace = OLapp.getNamespace("MAPI")​
Set OLinbox = OLspace.getDefaultFolder(olFolderInbox)​
Set oItem = OLinbox.Items​
oItem.Sort "?[receivedTime]", True 'tri décroissant​
'oItem.Sort "?[Reçu]", True 'tri décroissant​
For Each oMt In oItem​
Debug.Print oMt.senderName & " - " & oMt.receivedTime​
Next oMt​
OLapp.Quit​

Les fichiers textes
  • Ecrire la valeur de la cellule A1 dans une fichier texte , par l'instruction Append
    Remarques : Les données viennent s'inscrire à la suite des lignes existantes .Si le fichier .Txt n'existe pas , il sera créé automatiquement .​
    Sub excelVersFichierTexte()​
    Dim Cible As Integer​
    Cible = freeFile​
    Open "C:\Mes documents\michel excel\essai.txt" For Append As #Cible​
    Print #Cible, Range("A1") 'renvoie valeur cellule A1 dans fichier txt​
    Close #Cible​
    End Sub​
  • Ecrire la valeur de la cellule A1 dans une fichier texte , par l'instruction Output
    Remarques : Si le fichier existe , les anciennes données seront écrasées .Si le fichier .Txt n'existe pas , il sera créé automatiquement .​
    Sub excelVersFichierTexte_V02()​
    Dim Fichier As String​
    Fichier = "C:\Documents and Settings\michel\dossier\general\excel\Fichier.Txt"​
    Open Fichier For Output As #1​
    Print #1, Range("A1") 'renvoie la valeur cellule A1 dans le fichier txt​
    Close​
    End Sub​
  • Importer les données d'un fichier texte dans un classeur
    dans cet exemple le séparateur du fichier texte est le point virgule ";"​
    Sub lireFichierTexte()​
    Dim infosLigne As String​
    Dim i As Integer, x As Integer​
    Dim Tableau() As String​
    Open "C:\Documents and Settings\michel\excel\monFichier.txt" For Input As #1​
    Do While Not EOF(1)​
    Line Input #1, infosLigne​
    i = i + 1​
    Tableau = Split(infosLigne, ";") 'le separateur est le point virgule​
    For x = 0 To UBound(Tableau)​
    Cells(i, x + 1) = Tableau(x)​
    Next​
    Loop​
    Close #1​
    End Sub​
  • Lire un fichier Texte : boucler sur toutes les lignes du fichier
    Dans l'exemple , un message s'affiche si le début de la ligne commence par "XLD"​
    Sub lireFichierTexte()​
    Dim infosLigne As String​
    Open "C:\Mes documents\xl\fichierTexte.txt" For Input As #1​
    Do While Not EOF(1)​
    Line Input #1, infosLigne​
    If Left(infosLigne, 3) = "XLD" Then Msgbox infosLigne​
    Loop​
    Close #1​
    End Sub​
  • Substituer des donnees dans un fichier texte , 1ere solution
    La premiere consiste à creer une copie contenant les modifications .​
    Dans l'exemple la valeur de remplacement est récupérée dans la cellule A1​
    Sub modifierFichierTexteV01()​
    Dim valeur As Long​
    Dim Cible As String​
    Open "D:\dossier\general\excel\test.txt" For Input As #1 'recup données fichier texte​
    valeur = fileLen("D:\dossier\general\excel\test.txt")​
    Cible = Input(valeur, 1)​
    Close 1​
    Cible = Application.Substitute(Cible, "ancienMot", Range("A1")) 'remplacement mot cible​
    Open "D:\dossier\general\excel\testCopie.txt" For Append As #1 'creation nouveau fichier​
    Print #1, Cible​
    Close 1​
    End Sub​
  • Substituer des donnees dans un fichier texte , 2eme solution
    la deuxieme proposition est plus radicale , mais aussi plus risquée .​
    qui consiste à recuperer les infos du fichier d'origine dans une​
    variable , effectuer la modification des données , supprimer le ficher​
    d'origine puis creer une nouveau fichier portant le meme nom ,​
    pour y inserer les données modifiées​
    Sub modifierFichierTexteV02()​
    Dim valeur As Long​
    Dim Cible As String​
    Open "D:\dossier\general\excel\test.txt" For Input As #1 'recup données fichier texte​
    valeur = fileLen("D:\dossier\general\excel\test.txt")​
    Cible = Input(valeur, 1)​
    Close 1​
    Cible = Application.Substitute(Cible, "ancienMot",Range("A1")) 'remplace mot cible​
    Kill "D:\dossier\general\excel\test.txt" 'suppression fichier d'origine​
    Open "D:\dossier\general\excel\test.txt" For Append As #1 'nouveau fichier​
    Print #1, Cible​
    Close 1​
    End Sub​
  • Afficher un fichier texte dans une msgBox
    Sub fichierTexteVersExcel()​
    Dim Valeur As Long​
    Dim Cible As String​
    Open "D:\dossier\general\excel\test.txt" For Input As #1​
    Valeur = fileLen("D:\dossier\general\excel\test.txt")​
    Cible = Input(Valeur, 1)​
    Close 1​
    msgBox Cible​
    End Sub​
  • Compter le nombre de lignes d'un fichier texte
    Const forReading = 1​
    Sub nombreLignesFichierTexte()​
    'Activer la reference Microsoft Scripting Run Time​
    Dim fso As Scripting.fileSystemObject​
    Dim Fichier As Scripting.textStream​
    Set fso = createObject("Scripting.fileSystemObject")​
    Set Fichier = fso.openTextFile _​
    ("C:\Documents and Settings\michel\monFichier.txt", forReading)​
    Fichier.readAll​
    msgBox "nombre de lignes : " & Fichier.Line​
    Fichier.Close​
    End Sub​
  • Ouvrir un fichier texte dans Excel
    Sub ouvrirFichierTxt()​
    Workbooks.openText Filename:= _​
    "C:\Documents and Settings\michel\dossier\fichierTexte.txt", Origin:=xlWindows, startRow:=1, dataType:=xlFixedWidth​
    End Sub​
  • Importer un fichier texte dont le séparateur est une virgule
    L'argument Comma:=True​
    Workbooks.openText Filename:=leFichier, Origin:=xlWindows, _​
    startRow:=1, dataType:=xlDelimited, textQualifier:=xlDoubleQuote, _​
    consecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False​
  • Importer un fichier texte dont le séparateur est un point d'exclamation
    L'argument "Other" doit etre à True , et l'argument suivant "otherChar" doit etre précisé : otherChar:="!"​
    Workbooks.openText Filename:=leFichier, Origin:=xlWindows, _​
    startRow:=1, dataType:=xlDelimited, textQualifier:=xlDoubleQuote, _​
    consecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _​
    Space:=False, Other:=True, otherChar:="!", fieldInfo:=Array(1, 1)​
  • Transfert d'un tableau vers un fichier texte
    Sub exportFeuille_versFichierTexte()​
    Dim Plage As Range​
    Dim i As Long​
    Dim j As Byte​
    Dim Resultat As String​
    Dim Tableau As Variant​
    Set Plage = Feuil1.usedRange.Cells​
    Tableau = Plage​
    Open "c:\exportFeuille.txt" For Output As #1​
    For i = 1 To UBound(Tableau, 1)​
    For j = 1 To UBound(Tableau, 2)​
    Resultat = Resultat & Tableau(i, j) & ";" 'adaptez le separateur​
    Next​
    Resultat = Left(Resultat, Len(Resultat) - 1)​
    Print #1, Resultat​
    Resultat = ""​
    Next​
    Close #1​
    End Sub​
  • Supprimer les lignes en double dans un fichier texte
    Option Explicit​
    Const forReading = 1​
    Const forWriting = 2​
    Sub supprimetTexteEndouble()​
    'necessite d'activer la reference Microsoft Scripting Run Time​
    Dim objDictionary As Scripting.Dictionary​
    Dim objFSO As Scripting.fileSystemObject​
    Dim objFile As Scripting.textStream​
    Dim strKey 'As ?​
    Dim strName As String​
    Set objDictionary = createObject("Scripting.Dictionary")​
    Set objFSO = createObject("Scripting.fileSystemObject")​
    Set objFile = objFSo_OpenTextFile _​
    ("C:\Documents and Settings\michel\dossier\general\excel\monFichier.txt", forReading)​
    Do Until objFile.atEndOfStream​
    strName = objFile.readLine​
    If Not objDictionary.Exists(strName) Then objDictionary.Add strName, strName​
    Loop​
    objFile.Close​
    Set objFile = objFSo_OpenTextFile _​
    ("C:\Documents and Settings\michel\dossier\general\excel\monFichier.txt", forWriting)​
    For Each strKey In objDictionary.Keys​
    objFile.writeLine strKey​
    Next​
    objFile.Close​
    End Sub​
  • Supprimer une ou plusieurs lignes dans un fichier texte
    'Source : Willi 26/03/2006​
    'http://www.codyx.org/snippet_supprimer-ou-plusieurs-lignes-dans-fichier_76.aspx​
    Dim colLignes As New Collection​
    Dim Ff As Integer, i As Integer​
    Dim sLigne As String​
    Ff = freeFile​
    'Lecture du fichier, envois chaque ligne dans la collection​
    Open "C:\Documents and Settings\michel\dossier\monFichier.txt" For Input As #Ff​
    While Not EOF(Ff)​
    Line Input #Ff, sLigne​
    colLignes.Add sLigne​
    Wend​
    Close #Ff​
    'Suppression des lignes 1 , 3 et 10​
    colLignes.Remove 10​
    colLignes.Remove 3​
    colLignes.Remove 1​
    'Réecriture du fichier​
    Open "C:\Documents and Settings\michel\dossiermonFichier.txt" For Output As #Ff​
    For i = 1 To colLignes.Count​
    Print #Ff, colLignes(i)​
    Next​
    Close #Ff​
  • Regrouper deux fichiers texte : Ajouter le contenu du Fichier2 dans le Fichier1
    Remarque : cette méthode fonctionne aussi pour les fichiers html​
    Sub jointureDeuxFichiersTexte()​
    'Le contenu du Fichier2 va etre ajouté dans le Fichier1​
    Const forReading = 1, forWriting = 2, forAppending = 8​
    Const tristateUseDefault = -2, tristateTrue = -1, tristateFalse = 0​
    Dim Fs As Object​
    Dim Fichier1 As Object, Fichier2 As Object​
    Dim Contenu2 As String 'variable pour récupérer le contenu du Fichier2​
    Set Fs = createObject("Scripting.fileSystemObject")​
    Set Fichier2 = Fs.openTextFile("C:\fichierSource.txt", forReading, tristateFalse)​
    Set Fichier1 = Fs.openTextFile("C:\fichierDestination.txt", forAppending, tristateFalse)​
    Contenu2 = Fichier2.readAll​
    Fichier1.Write (Contenu2)​
    Fichier1.Close​
    Fichier2.Close​
    End Sub​
Si vous constatez des erreurs dans la page n'hesitez pas à m'en faire part .
Toutes vos idees sont les bienvenues .
Michel , Mise à jour le 25 Novembre 2006
 
Dernière modification par un modérateur:

Discussions similaires

M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
291
Gégé-45550
Gégé-45550
N
  • Question
Microsoft 365 Code VBA
Réponses
7
Affichages
508
TooFatBoy
TooFatBoy
G
  • Question
Microsoft 365 Vba Excel l'instruction Set OutApp = CreateObject("Outlook.Application") bloque excel
Réponses
2
Affichages
111
laurent950
laurent950
M
  • Résolu(e)
XL 2021 PUBLIPOSTAGE : Mise en forme du corps de message issu d'une cellule excel (VBA)
Réponses
4
Affichages
287
Minus&Cortex
M
N
  • Question
Microsoft 365 Envoi via Excel avec OutlookNew
Réponses
1
Affichages
121
wDog66
wDog66
oguruma
EXCEL :: Axes des abscisses dynamiques d'un graphique construit à partir d'un tableau croisé dynamique - Variante
Réponses
0
Affichages
280
oguruma
oguruma
G
  • Résolu(e)
XL 2021 Envoie d'informations sélectionnés par mail
Réponses
3
Affichages
143
TooFatBoy
TooFatBoy
Nicolas JACQUIN
  • Résolu(e)
XL 2021 Aide adaptation code vba pour complément
Réponses
7
Affichages
231
Nicolas JACQUIN
Nicolas JACQUIN
B
  • Question
XL 2021 Transfert tableau structuré EXCEL à un endroit précis de WORD
Réponses
8
Affichages
705
job75
job75
oguruma
EXCEL :: Exporter un onglet/plage de cellules dans un fichier PDF
Réponses
0
Affichages
306
oguruma
oguruma

Membres actuellement en ligne

17 membres et 322 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 422
Messages
2 109 447
Membres
110 482
dernier inscrit
ilyxxxh