[MichelXld]

Les sujets abordés dans cette page :

• Piloter d'autres applications depuis Excel , Piloter ( Word , Outlook , Power Point ) , Les fichiers texte

Lien vers la wiki page 1 :Les feuilles , Les graphiques , Les images , Les propriétés des classeurs , Les sauvegardes , Les formes automatiques , Aleatoire , Les barres d'outils et les barres de menus , Les boites de dialogues intégrées , Les classeurs .

Lien vers la wiki page 2 : Les userforms : Les Checkbox , Les Labels , Les combobox , Les Commandbutton , Les Listbox ,Les Multipages , Les Frames , Les Textbox , Les imagesList , Les Treeview , Les Listview , Les Images , Les Webbrowser , Les calendriers , Les progressbar , Les Spreadsheet , Les Chartspaces , Les commonDialog , Les MSFlexGrid.

Lien vers la wiki page 3 :Piloter d'autres applications depuis Excel , Piloter ( Word , Outlook , Power Point ) , Les fichiers texte

Lien vers la wiki page 4 : Les fonctions mathématiques et trigonométriques , Les impressions , Les temporisations , Les fonctions , Les evenements , Excel , Les cellules , Copier & Coller , Les dates et les calendriers , Les spécificités Macintosh, Générer des fichiers Flash , Open Office

Lien vers la wiki page 5 : Les formules Excel , Les audits de formules , Les répertoires et les fichiers .

Lien vers la wiki page 6 : Les doublons , Les tris et les filtres , Les variables , Piloter les fichiers fermés (Excel , Access ,les fichiers DBF) .

Lien vers la wiki page 7 : Les commentaires , La gestion des erreurs , L'aide en ligne Excel , Les recherches dans un classeur, Les tableaux , Les pages html et internet , Windows Media Player , Le PC et le systême d'exploitation ,Piloter Flash , les types de boucles.

Lien vers la wiki page 8 : Piloter MSN Messenger et Windows Messenger , Les objets dans le feuille , Les liens hypertextes , Les formats , Visual basic editor , Les chaines de caractères , Les modules de classe.

Lien vers la wiki page 9 : Les mises en forme conditionnelles , Les Tableaux et graphiques Croisés Dynamiques , Gérer les fichiers XML depuis Excel , Piloter Open Office depuis Excel.

Lien vers la wiki page 10 : Le Publipostage Word / Excel.

Lien vers la wiki page 11 : Utiliser la librairie Windows Image Acquisition Automation Library v2.0 depuis Excel.

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

  Le lien sur le forum XLD

• Afficher une image avec " l'apercu des images et des telecopies Windows "

  Le lien sur le forum XLD

• 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)

  Le lien sur le forum XLD

  Le fichier zippé

  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

  Le lien sur le forum XLD

• 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

  D'autres informations sur le site Microsoft

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

  Le lien sur le forum XLD

  Le fichier zippé

• Transferer plusieurs tableaux Excel vers Word puis les redimensionner

  Le lien sur le forum XLD

• Exporter un tableau Excel filtré vers Word

  Le lien sur le forum XLD

  Le fichier zippé

• 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

  Le lien sur le forum XLD

  Le fichier zippé

  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

  Le lien sur le forum XLD

• Exporter une tableau Excel dans Word en appliquant un retrait de mise en page

  Le lien sur le forum XLD

• Chercher un mot dans tous les documents Word d'un répertoire

  Le lien sur le forum XLD

  Le fichier zippé

• Lister les propriétés d'un document Word

  Le lien sur le forum XLD

• Insérer , redimensionner et positionner une image dans un document Word existant

  Le lien sur le forum XLD

• Coller dans Word une selection de cellules , au format image Bitmap

  Le lien sur le forum XLD

• Modifier les marges dans un document Word

  Le lien sur le forum XLD

• Remplacer un mot dans un fichier Word

  Le lien sur le forum XLD

• 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

  Le lien sur le forum XLD

• 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.A lignment = 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

  Le lien sur le forum XLD

• Regrouper tous les documents Word d'un répertoire , dans un fichier unique

  Le lien sur le forum XLD

  Un autre exemple qui permet de compiler les documents d'un repertoire de façon sélective

  Le lien sur le forum XLD

  Le fichier zippé

• Boucler sur les graphiques d'un classeur et les coller à l'emplacement de signets , dans un document Word

  Le lien sur le forum XLD

• 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.inline Shapes.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

  Le lien sur le forum XLD

• 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

  Le lien sur le forum XLD

• 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

  Le lien sur le forum XLD

  Le fichier zippé

• Ouvrir un classeur Excel depuis une macro Word

  Le lien sur le forum XLD

• 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).O LEFormat.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(wdHeaderFoot erPrimary)

  .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("B34").Copy

  'collage dans le pied de page Word

  With appWord.Selection.Sections(1).Footers(wdHeaderFoot erPrimary)

  .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

Visualiser les exemples

Utiliser la messagerie Outlook et Outlook Express depuis Excel

• La différence entre Outlook et Outlook Express.

  Le lien vers le site Microsoft

• 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

  Le lien sur le forum XLD

• Creer et gerer des groupes de diffusion dans Excel

  Le fichier zippé dans la zone telechargement XLD

• 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

  Le lien sur le forum XLD

  une autre méthode

  Le lien sur le forum XLD

• Envoyer un mail avec le chemin d'un répertoire réseau , en lien hypertexte dans le corps du message

  Le lien sur Internet

• 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"

  .Body = "http://www.excel-downloads.com" & vbLf & "monMail@xld.fr"

  .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

  Le lien sur le forum XLD

• Envoyer un mail avec texte multiligne et sans message de confirmation , méthode CDO

  Le lien sur le forum XLD

• Envoyer un mail en automatique en utilisant le contenu d'un fichier texte comme corps du message

  Le lien sur le forum XLD

• 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

  .To = "michelxld@yahoo.fr"

  .Subject = "Le sujet traité "

  .Body = "Bonjour , " & vbLf & "Vous trouverez ci joint..."

  .Attachments.Add "C:\Documents and Settings\michel\dossier\general\excel\monFichier.t xt"

  '.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

  Le lien sur le forum XLD

• 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

  Le lien sur le forum XLD

  Le fichier zippé

• Créer des rendez vous en masse , à partir d'un tableau Excel

  Le lien sur le forum XLD

  Le fichier zippé

• 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

  Le lien sur le forum XLD

• 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()

  'http://support.microsoft.com/default.aspx?scid=kb;en-us;816644

  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 )

  Le lien sur le forum XLD

• Les evenements dans Outlook : Lancer une macro Excel depuis Outlook , lors de l'envoi d'un message .

  http://www.excel-downloads.com/forums/2-144556-demarrer-macro-excel-via-outlook.htm

  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(olFold erContacts)

  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(olFold erContacts)

  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

  Le fichier zippé

• 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

  Le lien sur Internet

• 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

  Visualiser la macro

• 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

  .Navigate "http://www.developpez.com"

  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

  .To = "destinataire@mail.fr"

  .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

  '.From = "youralias@yourdomain.com"

  .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

  Le lien sur Internet

• 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(olFold erContacts)

  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()

  'http://www.excelforum.com//showthread.php?t=478209

  '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(olFold erContacts)

  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()

  'source : http://microsoft.supinfo.com/scripts/14082/

  '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.t xt", 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.t xt", 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