[REF] Wiki Page 7 de MichelXld

[MichelXld]

Les sujets abordés dans cette page 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 .​

Généralités Excel - page 1
Ce qui touche aux userforms - page 2
Piloter d'autres applications depuis Excel - page 3
Fonctions, événements, dates et calendriers - page 4
Formules, audits, répertoires et fichiers - page 5
Doublons, tris et filtres, variables, fichiers fermés, Access - page 6
Commentaires, gestion des erreurs, aide en ligne, recherches, tableaux, pages html, PC et système d'exploitation - page 7
Les objets dans le feuille, liens hypertextes, formats, Visual basic editor, chaines de caractères, modules de classe- page 8
Les Tableaux et graphiques Croisés Dynamiques, fichiers XML - page 9
Le Publipostage Word / Excel - page 10
Librairie Windows Image Acquisition Automation Library v2.0 - page 11​

Les commentaires

• Compter le nombre de commentaires dans la feuille active
  
  msgBox activeSheet.Comments.Count​
• Liste des commentaires dans une feuille
  
  Sub listeCommentairesfeuille()​
  Dim Cmnt As Comment​
  Dim Liste As String​
  On Error goTo Fin​
  For Each Cmnt In activeSheet.Comments​
  Liste = Liste & Cmnt.Parent.Address & " = " & Cmnt.Text & Chr(10) & Chr(10)​
  Next Cmnt​
  msgBox Liste​
  Exit Sub​
  Fin:​
  If Err.Number = 91 Then msgBox "Il n'y a pas de commentaires dans la feuille . "​
  End Sub​
• Ajouter un commentaire dans la cellule A1 , puis le mettre en forme
  
  Sub formatCommentaire()​
  Range("A1").addComment​
  Range("A1").Comment.Text Text:="Le Forum :" & Chr(10) & "XLD" & Chr(10) & ""​
  With Range("A1").Comment.Shape​
  .Width = 100 ' dimensions commentaire​
  .Height = 120​
  .oLEFormat.Object.Font.Size = 14 ' taille texte​
  .oLEFormat.Object.Interior.colorIndex = 3 ' couleur de fond​
  .textFrame.Characters.Font.colorIndex = 4​
  .textFrame.Characters.Font.Bold = True ' ecriture gras​
  .oLEFormat.Object.Font.Name = "Bangle" ' type de police​
  End With​
  End Sub​
• Extraire toutes les valeurs numeriques d'un commentaire
  
  Sub sommeDansCommentaire()​
  Dim i As Byte​
  Dim Cible As String​
  Dim Nombre As Double, Total As Double​
  Cible = Range("A1").Comment.Text 'recuperation valeur commentaire​
  Cible = Application.Substitute(Cible, ",", ".") 'pour que fonction Val puisse reconnaitre decimales​
  Cible = Application.Substitute(Cible, " ", "x") ' pour gerer deux nombres qui se suivent​
  For i = 1 To Len(Cible)​
  If isNumeric(Mid(Cible, i, 1)) Then​
  Nombre = Val(Mid(Cible, i, Len(Cible) - i + 1))​
  msgBox Nombre​
  Total = Total + Nombre​
  i = i + Len(Str(Nombre)) - 1​
  End If​
  Next​
  msgBox "Le total du commentaire : " & Total​
  End Sub​
• Controler s'il y a un commentaire dans la cellule A1
  
  Sub controleSiCommentaire()​
  If Range("A1").Comment Is Nothing Then​
  msgBox "il n'y a pas un commentaire dans la cellule A1"​
  Else​
  msgBox "il y a un commentaire dans la cellule A1"​
  End If​
  End Sub​
• Copier le commentaire de la cellule A1dans le commentaire de la cellule A2
  
  Sub collageCommentaire()​
  Range("A1").Copy​
  Range("A2").pasteSpecial Paste:=xlPasteComments​
  End Sub​
• Boucler sur les commentaires de la feuille et y colorer en rouge les chaines de caracteres égal à "XLD"
  
  Sub modificationCommentaires()​
  Dim Cmnt As Comment​
  Dim Cible As String​
  Dim i As Integer, Valeur As Integer​
  If activeSheet.Comments.Count = 0 Then Exit Sub​
  For Each Cmnt In activeSheet.Comments​
  Cible = Cmnt.Text​
  For i = 1 To Len(Cible)​
  Valeur = inStr(i, Cible, "XLD", vbTextCompare)​
  If Valeur = 0 Then​
  Exit For​
  Else​
  Cmnt.Shape.textFrame.Characters(Valeur, 6).Font.colorIndex = 3​
  i = Valeur + 7​
  End If​
  Next i​
  Next Cmnt​
  End Sub​
• Adapter la taille d'un commentaire en fonction du texte qu'il contient
  
  Range("A1").Comment.Shape.textFrame.autoSize = True​
• Des commentaires conditionnels : une démo de Didier , myDearFriend
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Créer un commentaire dans la cellule A1 et y insérer une image
  
  With Range("A1")​
  .addComment​
  .Comment.Shape.Fill.userPicture "C:\Image2.jpg"​
  End With​
• Insérer une image dans un commentaire et redimensionner le commentaire à la taille de cette image
  
  Sub ajoutImageCommentaire()​
  Dim Nom As Variant, Repertoire As Variant​
  Dim C As Range​
  Repertoire = activeWorkbook.Path & "\Photos\"​
  For Each C In Selection​
  Nom = C.Value​
  If Not C = "" Then​
  With C​
  .addComment​
  .Comment.Shape.Fill.userPicture Repertoire & Nom & ".jpg"​
  .Comment.Visible = False 'Masque le commentaire​
  End With​
  With C.Comment.Shape​
  .Width = Val(dimensionsImage(Repertoire, Nom & ".jpg", 27))​
  .Height = Val(dimensionsImage(Repertoire, Nom & ".jpg", 28))​
  End With​
  End If​
  Next​
  End Sub​
  Public Function dimensionsImage(Chemin As Variant, nomImage As Variant, Itm As Integer)​
  Dim objShell As Object, strFileName As Object​
  Dim objFolder As Object​
  Set objShell = createObject("Shell.Application")​
  Set objFolder = objShell.nameSpace(Chemin)​
  Set strFileName = objFolder.Items.Item(nomImage)​
  dimensionsImage = objFolder.getDetailsOf(strFileName, Itm)​
  Set objShell = Nothing​
  Set strFileName = Nothing​
  Set objFolder = Nothing​
  End Function​

La gestion des erreurs

• La liste des codes erreur
  
  CodeErreurVba​
• On Error goTo
  
  Cette instruction permet d'indiquer l'emplacement de la procédure qui gère les erreurs . Lorsqu'une erreur survient la macro passe à la ligne spécifiée : "errorHandler" dans l'exemple ci dessous​
  Sub maMacro()​
  On Error goTo errorHandler 'placé en début de macro : si une erreur survient, on va à la ligne "errorHandler"​
  '…​
  'La procedure​
  '…​
  Exit Sub' permet d'éviter la partie gestion d'erreur , si la macro s'est déroulés sans encombre​
  errorHandler:​
  msgBox Err.Number & vbLf & Err.Description' indique le numéro et la description de l'erreur survenue​
  '(voir le chapitre suivant pour plus de détails sur les codes d'erreur )​
  End Sub​
• On Error Resume Next
  
  Cette instruction , placée en début de macro , Permet en cas d'erreur de continuer la procédure en passant directement à la ligne suivante​
  A utiliser avec précaution car vous ne serez pas informé qu'une erreur est survenue et vous ne pourrez pas localiser l'origine du problème dans le cas où le "bug" serait préjudiciable au résultat final de votre macro​
• On Error goTo 0
  
  Permet de désactiver la gestion d'erreur dans la procédure en cours​
• Afficher la description d'un code erreur spécifique
  
  Debug.Print Error(75)​
• Afficher la description d'une erreur survenue lors du déroulement d'une macro
  
  Sub Test()​
  Dim X As Single​
  On Error goTo errorHandler​
  X = 5 / 0 'exemple : la division par 0 va creer une erreur​
  '....​
  errorHandler:​
  Debug.Print Err.Description​
  End Sub​
• Gérer les erreurs dans une macro , afficher des informations et ouvrir l'aide associée
  
  Sub testErreur()​
  On Error goTo errorHandler​
  'la procedure qui va bugguer , par exemple une division par 0:​
  Dim x As Integer​
  x = 2 / 0​
  errorHandler:​
  msgBox "Code Erreur : " & Err.Number & vbLf & "Description: " & Err.Description & _​
  vbLf & Err.Source & vbLf & "Index de l'aide VBA :" & Err.helpContext & vbLf & Err.helpFile​
  msgBox "Cliquez sur le bouton AIDE pour afficher l'aide en ligne", vbMsgBoxHelpButton, , Err.helpFile, Err.helpContext​
  End Sub​
• Récupérer le numéro de ligne qui a provoqué une erreur (utilisation de la fonction ERL)
  
  Ce lien n'existe plus​

L'aide en ligne Excel

• L'aide en ligne Excel
  
  Lorsque vous etes dans visual Basic Editor , vous pouvez accéder à l'aide intégrée d'Excel : Plaçez le curseur de la souris sur un des termes de votre macro , ensuite appuyez sur la touche "F1"​
• Afficher l'aide en ligne Excel
  
  Sub afficherAideExcel()​
  Application.Help "XLMAIN10.chm" 'excel2002​
  End Sub​
• Afficher l'aide en ligne VBA
  
  Sub afficherAideVBAexcel()​
  Application.Help "vbLR6.chm" 'excel2002​
  End Sub​
• Gestion des erreurs dans les formules Excel2002
  
  Rechercher toutes les erreurs dans la Feuil1​
  Private Sub Worksheet_Calculate()​
  'testé sous XP​
  Dim Valeur As Range​
  Dim Resultat As String, Message As String​
  For Each Valeur In Sheets("Feuil1").usedRange​
  If worksheetFunction.isErr(Valeur) = True Then​
  Valeur.showErrors​
  Select Case Valeur​
  Case CVErr(xlErrDiv0)​
  Resultat = "#DIV/0!"​
  Case CVErr(xlErrNA)​
  Resultat = "#N/A"​
  Case CVErr(xlErrName)​
  Resultat = "#NOM?"​
  Case CVErr(xlErrNull)​
  Resultat = "#NULL!"​
  Case CVErr(xlErrNum)​
  Resultat = "#NOMBRE!"​
  Case CVErr(xlErrRef)​
  Resultat = "#REF!"​
  Case CVErr(xlErrValue)​
  Resultat = "#VALEUR!"​
  End Select​
  msgBox "Il y a une erreur de type " & Resultat _​
  & " dans la formule de la cellule " & Valeur.Address​
  End If​
  Next​
  Message = msgBox("Voulez vous ouvir l'aide en ligne Excel ? ", _​
  vbYesNo, "Informations complementaires sur les types d'erreur")​
  If Message = vbYes Then Application.Help "XLMAIN10.chm", 60309​
  '( source classeur "Fonctions 2000_XP.xls" de Ti )​
  'adapter le nom du fichier et l' helpcontextId selon la version d'excel​
  'If Message = vbYes Then Application.Help "XLMAIN09.chm", 60309'pour Excel2000​
  End Sub​
  'ensuite pour supprimer les fleches d'audit ( macro à placer dans un module )​
  Sub effacerFlechesAudit()​
  Worksheets("Feuil1").clearArrows​
  End Sub​
• Lister les cellules contenant des erreurs dans la plage de cellule A1:A100
  
  Sub identifierCellulesContenantErreurs()​
  Dim Plage As Range, Cible As Range​
  Set Plage = Range("A1:A100")​
  On Error Resume Next​
  Set Cible = Plage.specialCells(xlCellTypeFormulas, xlErrors)​
  If Not Cible Is Nothing Then msgBox Cible.Address(0, 0)​
  End Sub​
• Utiliser le bouton d'aide dans un msgBox (vbMsgBoxHelpButton)
  
  Le lien sur le forum XLD​
• Utiliser un fichier d'aide(.chm) personnel dans Excel
  
  Lors de la distribution de vos projets , il peut etre interessant d'associer des fichiers d'aide spécifiques qui seront mis à la disposition des utilisateurs.​
  Ce lien n'existe plus​
  Des informations complémentaires sur le site de Microsoft :​
  http://support.microsoft.com/default.aspx?scid=kb%3Bfr%3B209843​
  Ce lien n'existe plus​
  Parmi les outils de création disponibles , il existe HTML Help Workshop, téléchargeable sur le site Microsoft.​
  Ce lien n'existe plus​

Les recherches dans un classeur

• Chercher un mot ou une valeur dans tous les classeurs ouverts
  
  Option Base 1​
  Sub chercherMots_tousClasseursOuverts()​
  Dim i As Integer, j As Integer, K As Integer, X As Integer​
  Dim Cible As String​
  Dim Cell As Range​
  Dim firstAddress As String, Resultat As String​
  Dim Tableau()​
  Application.screenUpdating = False​
  'Effacer les résultats précédents​
  thisWorkbook.Sheets(1).usedRange.Cells.clearContents​
  'Mot à chercher​
  Cible = inputBox(" Saisir le mot à rechercher : ", "Recherche", "Le mot")​
  If Cible = "" Then Exit Sub​
  'Boucle sur tous les classeurs ouverts​
  For K = 1 To Workbooks.Count​
  Workbooks(K).Activate​
  'boucle sur toutes les feuilles de chaque classeur​
  For i = 1 To Sheets.Count​
  Sheets(i).Activate​
  With Sheets(i).usedRange.Cells​
  Set Cell = .Find(Cible, Lookin:=xlValues)​
  If Not Cell Is Nothing Then​
  firstAddress = Cell.Address​
  Do​
  Cell.Select​
  'Mise en tableau des résultats trouvés​
  X = X + 1​
  reDim Preserve Tableau(3, X)​
  Tableau(1, X) = Workbooks(K).Name​
  Tableau(2, X) = Sheets(i).Name​
  Tableau(3, X) = "Cellule " & Cell.Address​
  Set Cell = .findNext(After:=activeCell)​
  Loop While Not Cell Is Nothing And Cell.Address <> firstAddress​
  End If​
  End With​
  Next i​
  Next K​
  If X <> 0 Then​
  thisWorkbook.Activate​
  For j = 1 To X​
  With thisWorkbook.Sheets(1)​
  Range("A65536").End(xlUp).Offset(1, 0) = Tableau(1, j)​
  Range("B65536").End(xlUp).Offset(1, 0) = Tableau(2, j)​
  Range("C65536").End(xlUp).Offset(1, 0) = Tableau(3, j)​
  End With​
  Next j​
  Else​
  msgBox "aucune valeur trouvée"​
  End If​
  Application.screenUpdating = True​
  End Sub​
• Rechercher un mot pouvant contenir des majuscules ou des minuscules
  
  Pour effectuer une recherche par VBA indépendamment de la casse (XLD=xld) , il faut saisir tout en haut du module ( avant la première macro ) : "Option Compare Text"​
  Exemple :​
  Option Compare Text​
  Sub maMacro()​
  .....​
  End Sub​
  Pour que la recherche soit sensible à la casse , utilisez : Option Compare Binary​
  Exemple :​
  Option Compare Binary​
  Sub maMacro()​
  .....​
  End Sub​

Les tableaux

• Des informations très complétes au sujet des tableaux , sur la Wiki Page de Zon
  
  LeKiKideZon​
• Transférer un tableau vers un fichier texte
  
  Lien supprimé​
• Transférer un tableau dans une Feuille Excel
  
  Sub tableauVersFeuilleExcel()​
  Dim i As Integer, j As Integer, X As Integer​
  Dim Tableau() As String​
  'définir le nombre de lignes​
  X = inputBox("Saisir le nombre de lignes : ", "Transfert tableau dans feuille Excel", 10)​
  If X = 0 Then Exit Sub​
  'insertion des données dans le tableau( X lignes et 2 colonnes )​
  reDim Tableau(X, 2)​
  For i = 0 To X - 1​
  For j = 0 To 1​
  Tableau(i, j) = "Valeur" & i & j​
  Next j​
  Next i​
  'transfert du tableau dans la feuille Excel​
  Range("A1:B" & UBound(Tableau)) = Tableau​
  End Sub​
• Trier les données d'un tableau
  
  Sub tri_Tableau()​
  Dim Valeur As Byte​
  Dim i As Integer​
  Dim Cible As Variant​
  Dim Tableau()​
  reDim Tableau(0 To 9) 'remplissage tableau avec cellules A1:A10​
  For i = 0 To UBound(Tableau())​
  Tableau(i) = Cells(i + 1, 1)​
  Next i​
  Do 'tri​
  Valeur = 0​
  For i = 0 To UBound(Tableau) - 1​
  If Tableau(i) < Tableau(i + 1) Then​
  Cible = Tableau(i)​
  Tableau(i) = Tableau(i + 1)​
  Tableau(i + 1) = Cible​
  Valeur = 1​
  End If​
  Next i​
  Loop While Valeur = 1​
  For i = 0 To UBound(Tableau) 'verification tri​
  msgBox Tableau(i)​
  Next i​
  End Sub​
• Trier une des colonnes d'un tableau multicolonnes
  
  Ce lien n'existe plus​
• Récupérer dans un tableau uniquement les cellules visibles de la colonne A
  
  Dim Plage As Range​
  Dim Cell As Range​
  Dim i As Integer​
  Dim Tableau() As String​
  Set Plage = Sheets(1).Range("A1:A" & Range("A65536").End(xlUp).Row)​
  Set Plage = Plage.specialCells(xlCellTypeVisible)​
  reDim Tableau(0 To Plage.Count - 1)​
  For Each Cell In Plage​
  Tableau(i) = Cell​
  i = i + 1​
  Next​
• Réinitialiser un tableau
  
  et libèrer de l'espace de stockage réservé aux tableaux dynamiques (infos issues de l'aide VBA Excel )​
  Erase monTableau​

Après la réinitialisation :​

Chaque élément d'un tableau numérique de taille fixe prend la valeur zéro.​

Dim numArray(10) As Integer​

Chaque élément d'un tableau de chaînes de taille fixe (longueur variable) accueille une chaîne de valeur nulle ("").​

Dim strVarArray(10) As String​

Chaque élément d'un tableau de chaînes de taille fixe (longueur fixe) prend la valeur zéro.​

Dim strFixArray(10) As String * 10​

Chaque élément d'un tableau de type Variant de taille fixe prend la valeur Empty.​

Dim varArray(10) As Variant​

Chaque élément d'un tableau de types définis par l'utilisateur est défini comme s'il s'agissait d'une variable distincte.​

Dim dynamicArray() As Integer​

reDim dynamicArray(10)​

• Vérifier si un tableau est vide
  
  Dim Tableau() As Long​
  Dim x As Variant​
  '...La procédure​
  On Error Resume Next​
  x = UBound(Tableau)​
  On Error goTo 0​
  If isEmpty(x) Then msgBox "Le tableau est vide"​

Les pages html et Internet

• Effectuer une requete Web depuis Excel
  
  Menu Donnees​
  Donnees Externe​
  Nouvelle requete sur le Web​
  saisies l'adresse de la page Html​
  selectionnes la ou les zones à importer​
  cliques sur le bouton "Importer"​
• Télécharger un fichier ZIP stocké sur un serveur FTP
  
  Le lien sur Internet​
• Télécharger une image web : utilisation des requètes winHttp
  
  Sub recupererImageWeb_winHttp()​
  'source :http://www.allhtml.com/forum/index.php?t=l&f=4&i=312103​
  'activer la reference Microsoft winHttp Services ,version 5.1​
  Dim b() As Byte​
  Dim h As Long​
  Dim oWinHttp1 As winHttp.winHttpRequest​
  h = freeFile​
  Open "C:\monImage.gif" For Binary As #h​
  Set oWinHttp1 = New winHttp.winHttpRequest​
  oWinHttp1.Open "GET", "Lien supprimé", False​
  oWinHttp1.Send​
  oWinHttp1.waitForResponse (30)​
  b() = oWinHttp1.responseBody​
  Set oWinHttp1 = Nothing​
  Put #h, 1, b()​
  Close #h​
  End Sub​
• Creer une page html depuis Excel
  
  cet exemple nécéssite d'etre connecté au web​
  Le lien sur le forum XLD​
  Lien supprimé​
• Un autre exemple qui affiche un texte d'information dans une fenetre Internet Explorer
  
  Lien supprimé​
• Enregistrer chaque onglet d'un classeur dans des pages Html dissociées
  Un lien est ajouté dans chaque page pour pouvoir naviguer entre les feuilles
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Ajouter un raccourci internet dans le dossier des Favoris
  
  Sub ajouterLienInternetDansFavoris()​
  Dim Fichier As String, cheminFavoris As String, siteURL As String​
  Dim Num As Integer​
  cheminFavoris = createObject("WScript.Shell").specialFolders("Favorites") 'récupère le chemin du dossier des Favoris​
  Fichier = cheminFavoris & "\XLD Mon forum préféré.url" 'adapter le nom du lien​
  siteURL = "http://www.excel-downloads.com" 'l'adresse de la page internet​
  Num = freeFile​
  Open Fichier For Output As Num​
  Print #Num, "[internetShortcut]"​
  Print #Num, "URL=" & siteURL​
  Close Num​
  End Sub​
  Une autre methode pour ajouter un lien dans les favoris​
  Sub ajoutLienFavoris()​
  'necessite d'activer la reference Windows Script Host Object Model​
  Dim xShell As IWshRuntimeLibrary.wshShell​
  Dim Raccourci As IWshRuntimeLibrary.WshURLShortcut​
  Dim dirBureau As String​
  Set xShell = createObject("WScript.Shell")​
  dirBureau = xShell.specialFolders("Favorites")​
  Set Raccourci = xShell.createShortcut(dirBureau & "\monLienPréféré.url")​
  Raccourci.targetPath = "http://www.excel-downloads.com"​
  Raccourci.Save​
  End Sub​
• Récupérer des informations sur des pages Html , et les piloter par macro (utilsation d'un Webbrowser )
  
  Changer le texte dans un bouton , puis appliquer le focus sur ce bouton​
  Afficher des informations générales sur une page html : date de la création de la page , date de la dernière modification , la taille de la page​
  Compter le nombre d'images d'une page html et lister les adresses , sans doublons​
  Piloter une page html par macro : Exemple sur le moteur de recherche XLD​
  Le lien sur le forum XLD​
  Le fichier zippé​
• Afficher le nom d'une page internet
  
  Sub afficherNomPageInternet()​
  'source : http://www.excelforum.com//showthread.php?t=333568​
  'activer la reference Microsoft Internet Controls​
  Dim IE As internetExplorer​
  Set IE = New internetExplorer​
  IE.Navigate "http://www.excel-downloads.com"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop​
  msgBox IE.locationName​
  IE.Quit​
  Set IE = Nothing​
  End Sub​
• Lister tous les liens existants dans une page Web
  
  Sub listeLiensPageWeb()​
  'nécéssite d'activer la référence Microsoft HTML Objects Library​
  'nécéssite d'activer la référence Microsoft Internet Controls​
  Dim IE As New internetExplorer​
  Dim x As Integer​
  Dim maPageHtml As HTMLDocument​
  IE.Navigate "http://www.excel-downloads.com"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop​
  Set maPageHtml = IE.Document​
  For x = 0 To maPageHtml.links.Length - 1​
  Cells(x + 1, 1) = maPageHtml.links(x)​
  Next​
  End Sub​
• Boucler sur toutes les images d'une page Web
  
  Private Sub commandButton3_Click()​
  'michelxld le 10.01.2005​
  'boucler sur toutes les images d'une page Web​
  'pour recuperer l'adresse et leurs dimensions​
  'testé avec WinXP & Excel2002​
  'nécéssite d'activer la référence Microsoft HTML Objects Library​
  'nécéssite d'activer la référence Microsoft Internet Controls​
  Dim IE As internetExplorer​
  Dim maPageHtml As HTMLDocument​
  Dim imgHtml As HTMLImg​
  Dim i As Integer​
  Set IE = createObject("internetExplorer.Application")​
  IE.Visible = True​
  IE.navigate "http://www.excel-downloads.com"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop 'attend la fin du chargement pour continuer la procedure​
  Set maPageHtml = IE.document​
  'compte le nombre d'images dans la page​
  msgBox "nombre d'images dans la page : " & maPageHtml.images.Length​
  For i = 0 To maPageHtml.images.Length - 1 'boucle sur les images​
  Set imgHtml = maPageHtml.images.Item(i)​
  Debug.Print imgHtml.src 'adresse image​
  Debug.Print imgHtml.Width 'largeur image​
  Debug.Print imgHtml.Height 'hauteur image​
  Next i​
  End Sub​
• Piloter les objets d'une page Web : Les listes de choix , les zones de texte et les boutons
  
  Sub piloterPageWeb()​
  'nécéssite d'activer la référence Microsoft HTML Objects Library​
  'nécéssite d'activer la référence Microsoft Internet Controls​
  Dim i As Integer​
  Dim IE As internetExplorer​
  Dim maPageHtml As HTMLDocument​
  Dim Helem As IHTMLElementCollection​
  Set IE = createObject("internetExplorer.Application")​
  IE.Visible = True​
  IE.navigate "http://mail1.voila.fr/webmail/login.html?REDIRECTION_INIT=TRUE"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop 'attend la fin du chargement​
  Set maPageHtml = IE.document​
  Set Helem = maPageHtml.getElementsByTagName("input")​
  'exemple de boucle pour lister les objets type "select"(listes de choix) dans la page​
  'Dim Hsel As IHTMLElementCollection​
  'Set Hsel = maPageHtml.getElementsByTagName("select")​
  'For i = 0 To Hsel.Length - 1​
  'msgBox Hsel(i).getAttribute("name") & " / " & Hsel(i).getAttribute("value")​
  'Next i​
  '(boucle pour lister les objets type "input" de la page)​
  'For i = 0 To Helem.Length - 1​
  'msgBox Helem(i).getAttribute("name") & " / " & Helem(i).getAttribute("value")​
  'une autre possibilité pour déclencher le clic ( non utilisable dans cet exemple)​
  'If Helem(i).getAttribute("value") = "texte du bouton" Then Helem(i).Click​
  'Next i​
  Helem(7).innerText = "piloter page internet VB" 'champ de saisie mots clés​
  Helem(8).Click 'simulation clic​
  End Sub​
• Accéder à un objet input spécifique
  
  Sub piloterPageHTML()​
  'nécessite d'activer les références​
  'Microsoft HTML Objects Library et Microsoft Internet Controls​
  Dim IE As internetExplorer​
  Dim maPageHtml As HTMLDocument​
  Dim Helem As IHTMLElementCollection​
  Dim Hx As IHTMLInputElement​
  Set IE = createObject("internetExplorer.Application")​
  IE.Visible = True​
  IE.navigate "http://www.leSite.fr"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop 'attend la fin du chargement​
  Set maPageHtml = IE.document​
  Set Helem = maPageHtml.getElementsByTagName("input")​
  Set Hx = Helem.Item("number") 'Définit le champ Input contenu dans la page​
  Hx.Value = "07;11;25;27;34" 'Insere les données​
  End Sub​
• Exporter le contenu d'une page internet dans un fichier texte
  
  Sub exporterPageInternetDansfichierTexte()​
  'La source : http://www.excelforum.com//showthread.php?t=335124​
  'necessite d'activer la reference Microsoft Internet Controls​
  Dim IE As internetExplorer​
  Dim nFile As Integer​
  Set IE = createObject("internetExplorer.Application")​
  With IE​
  .Visible = False​
  .Silent = True​
  .Navigate "http://www.excel-downloads.com"​
  Do Until .readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop 'attend la fin du chargement​
  nFile = freeFile​
  Open "C:\xldtest.txt" For Output Shared As #nFile​
  Print #nFile, .Document.documentElement.innerText​
  'Print #nFile, .document.documentElement.innerHTML​
  Close #nFile​
  .Quit​
  End With​
  Set IE = Nothing​
  End Sub​
• Enregistrer une page Html dans un document Word
  
  Sub enregistrerPageHtml_dansWord()​
  Dim wordApp As Word.Application​
  Dim wordDoc As Word.Document​
  Set wordApp = createObject("word.application")​
  wordApp.Visible = True​
  Set wordDoc = wordApp.Documents.Open(Filename:="Ce lien n'existe plus")​
  With wordDoc​
  .pageSetup.Orientation = wdOrientLandscape​
  .saveAs "C:\laSauvegardeWord.doc"​
  End With​
  End Sub​
• Lister les fenetres Internet Explorer ouvertes
  
  Remarque : les fenetres de l'explorater Windows sont prises en compte​
  Sub listerFenetres_IE_Ouvertes()​
  'activer la référence "Microsoft Internet Controls"​
  Dim IE As internetExplorer​
  Dim winShell As New shellWindows​
  On Error Resume Next​
  For Each IE In winShell​
  If IE.LocationURL <> "" Then msgBox IE.LocationURL​
  'IE.Quit 'option pour fermer les fenetres​
  Next IE​
  End Sub​
  Une autre solution sans avoir besoin de déclarer la librairie​
  Sub listerFenetres_IE_Ouvertes_V02()​
  Dim IE As Object, Sh As Object, Wn As Object​
  Set Sh = createObject("Shell.Application")​
  Set Wn = Sh.Windows​
  For Each IE In Wn​
  If IE.LocationURL <> "" Then msgBox IE.LocationURL​
  'IE.Quit 'option pour les fermer​
  Next IE​
  Set Wn = Nothing​
  Set Sh = Nothing​
  End Sub​
• Récupérer les meta informations d'une page Web ( keyWords , description , title )
  
  Le lien sur le forum XLD​
• Piloter une liste de choix dans une page Web
  
  Le lien sur Internet​
• Ouvrir une page IE en plein écran
  
  Le lien sur le forum XLD​
• Imprimer une page Web
  
  Sub imprimerPageWeb()​
  Dim IE As internetExplorer​
  Set IE = createObject("internetExplorer.Application")​
  IE.Visible = True​
  IE.navigate "http://www.mappy.fr"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop​
  IE.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER​
  End Sub​
• Importer des tableaux contenus dans des pages Web vers une feuille Excel
  
  Le lien sur Internet​
• Utiliser un tableau Excel dans une page Web ( Spreadsheet ) et exporter / sauvegarder le résultat dans un classeur
  
  Lien supprimé​
• Modifier une page Html par macro
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Vérifier l'état de la connection au réseau
  
  Voir le message du 26/07/2005 10:41​
  Le lien sur le forum XLD​
• Rafraichir une page Web
  
  Sub rafraichirPageWeb()​
  Dim IE As internetExplorer​
  Set IE = createObject("internetExplorer.Application")​
  IE.Visible = True​
  IE.navigate "http://www.mappy.fr"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop​
  IE.ExecWB OLECMDID_REFRESH, OLECMDEXECOPT_DONTPROMPTUSER​
  End Sub​
• Changer le titre de la page html
  
  Set IE = createObject("internetExplorer.Application")​
  IE.Visible = True​
  IE.navigate "http://www.excel-downloads.com"​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop​
  IE.document.Title = "mon site préféré"​
• Déclencher un lien hypertexte dans une page Html
  
  Sub declencherLienPageWeb()​
  'Lien supprimé​
  'nécéssite d'activer la référence Microsoft HTML Objects Library​
  'nécéssite d'activer la référence Microsoft Internet Controls​
  Dim IE As New internetExplorer​
  Dim Cible As HTMLAnchorElement​
  Dim Doc As HTMLDocument​
  IE.Navigate "http://www.excel-downloads.com"​
  IE.Visible = True​
  Do Until IE.readyState = READYSTATE_COMPLETE​
  doEvents​
  Loop​
  Set Doc = IE.Document​
  Set Cible = Doc.links(27)​
  Cible.Click​
  End Sub​
• Créer une page HTML en utilisant le résultat d'une requete ADO
  
  Ce lien n'existe plus​
• Lister les niveaux de sécurité Internet Explorer
  
  Dim objWMIService As Object, colIESettings As Object, strIESetting As Object​
  Dim strComputer As String​
  strComputer = "."​
  Set objWMIService = getObject("winmgmts:{impersonationLevel=impersonate}!\\" _​
  & strComputer & "\root\cimv2\Applications\MicrosoftIE")​
  Set colIESettings = objWMIService.execQuery("Select * from MicrosoftIE_Security")​
  For Each strIESetting In colIESettings​
  Debug.Print "Zone : " & strIESetting.Zone​
  Debug.Print "Niveau de sécurité : " & strIESetting.Level​
  Debug.Print "---"​
  Next​
• Ramener une fenêtre Internet Explorer au premier plan
  
  Ce lien n'existe plus​
• Lister les paramètres de connection Internet
  
  Ce lien n'existe plus​
• Lister le sommaire des paramètres Internet Explorer
  
  Ce lien n'existe plus​

Piloter Windows Media Player depuis Excel

• Jouer et arreter une séquence musicale
  
  Option Explicit​
  Dim Wmp As windowsMediaPlayer​
  'necessite d'activer la reference Windows Media Player​
  'michelxld le 11.05.2005​
  'pour le forum http://www.excel-downloads.com​
  Sub jouerMediaPlayer()​
  Set Wmp = createObject("WMPlayer.OCX.7")​
  Wmp.URL = "C:\Documents and Settings\michel\dossier\monFichier.mid"​
  Wmp.Controls.Play​
  End Sub​
  Sub arreterMediaPlayer()​
  If Wmp Is Nothing Then Exit Sub​
  Wmp.Controls.stop​
  End Sub​
• Afficher la durée de la séquence musicale en cours
  
  Dim valMin As Double, valSec As Double, S As Double​
  Set Wmp = createObject("WMPlayer.OCX.7")​
  Wmp.URL = "C:\monFichier.mp3"​
  While Wmp.playState = 9: doEvents: Wend​
  S = Wmp.currentMedia.Duration​
  valMin = Application.worksheetFunction.roundDown((S / 60), 0)​
  valSec = Application.worksheetFunction.roundDown(S, 0) - (valMin * 60)​
  msgBox Format(valMin, "00") & ":" & Format(valSec, "00")​
• Comment piloter Windows Media Player Depuis Excel (séquences et Playlist ) :
  
  Vous trouverez dans ce lien un ensemble d'exemples qui montre comment lancer et gérer , une séquence musicale , mais aussi une playList ( plusieurs séquences musicales dans une meme session )​
  Le lien sur le forum XLD​
• Modifier le titre d'un séquence
  
  Sub modifierTitreSequence()​
  Dim Xwmp As IWMPMedia​
  Dim Chemin As String​
  Chemin = "C:\Documents and Settings\michel\dossier musique"​
  Set Wmp = createObject("WMPlayer.OCX.7")​
  Wmp.currentPlaylist.Clear​
  Set Xwmp = Wmp.newMedia(Chemin & "\leFichierMusical.mid")​
  Wmp.currentPlaylist.insertItem 0, Xwmp​
  Xwmp.setItemInfo "title", "nom_Du_Titre" 'modifie le titre​
  doEvents​
  Wmp.Controls.Play​
  'testé OK avec des fichiers .mid , .wma​
  'à revoir pour les type .mp3​
  msgBox Wmp.currentMedia.getItemInfo("title") 'vérifie le titre modifié​
  End Sub​
• Retrouver l'index d'une séquence dans une playlist
  
  Dim Pl As IWMPPlaylist​
  Dim j As Integer, i As Integer​
  Dim Cible As String​
  Cible = windowsMediaPlayer1.Controls.currentItem.Name​
  Set Pl = windowsMediaPlayer1.currentPlaylist​
  j = Pl.Count​
  If Not j > 0 Then msgBox "il n'y a pas d'éléments dans la playlist"​
  For i = 0 To j - 1​
  If Cible = Pl.Item(i).Name Then​
  msgBox "L'index de la séquence " & Cible & " est : " & i​
  Exit For​
  End If​
  Next i​
• Compter le nombre de séquences dans la playlist
  
  windowsMediaPlayer1.currentPlaylist.Count​
• Lire la meme séquence en boucle
  
  windowsMediaPlayer1.URL = "C:\maMusique.mid"​
  windowsMediaPlayer1.Controls.Play​
  windowsMediaPlayer1.settings.setMode "loop", True​
• Ouvrir le lecteur de CD ou de DVD
  
  Dans cet exemple , 0 est l'index du 1er lecteur​
  Sub ouvrirLecteur()​
  Dim Wmp As Object, Lecteur As Object​
  Set Wmp = createObject("WMPlayer.OCX.7")​
  Set Lecteur = Wmp.cdromCollection.Item(0)​
  Lecteur.eject​
  End Sub​
• Intercepter le changement de statut d'un objet Windows Media Player inséré dans un Userform
  
  en utilisant l'Evenement "playStateChange"​
  Private Sub windowsMediaPlayer1_playStateChange(byVal newState As Long)​
  If windowsMediaPlayer1.Status = "Arrêté" Then msgBox "terminé"​
  'd'autres exemples de statuts :​
  'Connexion en cours...​
  'Lecture en cours​
  'Opération terminée​
  'Ouvrir le média​
  'Prêt​
  'Arrêté​
  'Modification du média en cours...​
  End Sub​
• Utiliser Windows Media Player pour afficher un message personnalisé
  
  Ce lien n'existe plus​
• Afficher ou Masquer la barre de controles de l'objet Windows Media Player .
  
  Dans la propriété uiMode , indiquez la valeur "none" pour masquer la barre de controles​
  Pour afficher la barre de controles , indiquez la valeur "full"​
• Afficher Windows Media player en plein écran
  
  Windows Media player doit etre en mode "Lecture en cours" pour utiliser cette option​
  Private Sub WMP_playStateChange(byVal newState As Long)​
  If WMP.Status = "Lecture en cours" Then WMP.fullScreen = True​
  End Sub​
• Positionner la lecture à un emplacement précis dans la séquence
  
  Private Sub commandButton1_Click()​
  'Chargement fichier & lecture​
  windowsMediaPlayer1.URL = "C:\maMusique.mp3"​
  'Positionnement à la 3eme minute​
  windowsMediaPlayer1.Controls.currentPosition = 180 'secondes​
  End Sub​

Le PC et le Systême d'exploitation

• Afficher la boite de dialogue Windows "Arreter l'ordinateur"
  
  Public Declare Function SHShutDownDialog Lib "shell32" Alias "#60" _​
  (Byval Yourguess As Long) As Long​
  'testé avec WinXP​
  Sub afficherFenetreArreterOrdinateur()​
  SHShutDownDialog 1​
  End Sub​
• Vérifier s'il y a un CD dans le lecteur
  
  Sub testPresenceCD()​
  On Error goTo Fin​
  Dir "D:\." 'adapter nom Lecteur​
  Msgbox "il y a un CD dans lecteur D ."​
  Exit Sub​
  Fin:​
  If Err = 52 Then Msgbox "il n'y a Pas de CD dans lecteur D ."​
  End Sub​
• Afficher le Label d'un CDRom
  
  Sub afficherLabelCDRom()​
  Dim Lecteur As String​
  Dim Fs As Object, D As Object​
  Lecteur = "D:\" 'adapter la lettre du lecteur​
  Set Fs = createObject("Scripting.fileSystemObject")​
  If Fs.driveExists(Lecteur) = True Then​
  Set D = Fs.getDrive(Lecteur)​
  If D.driveType = 4 Then '4="CDROM"​
  Set D = Fs.getDrive(Fs.getDriveName(Lecteur))​
  If (D.isReady) Then msgBox D.volumeName​
  End If​
  End If​
  End Sub​
• Retour sur le bureau , Minimiser toutes les applications
  
  Sub minimizerToutesLesApplications()​
  Dim WSHshell As Object, Shell As Object​
  Set WSHshell = createObject("WScript.Shell")​
  Set Shell = createObject("Shell.Application")​
  Shell.minimizeAll​
  End Sub​
• Maximaliser toutes les applications
  
  Sub maximaliserToutesLesApplications()​
  Dim WSHshell As Object, Shell As Object​
  Set WSHshell = createObject("WScript.Shell")​
  Set Shell = createObject("Shell.Application")​
  Shell.undoMinimizeAll​
  End Sub​
• Afficher quelques boites de dialogue Windows
  
  Sub afficherFenetresWinows()​
  'necessite d'activer reference Microsoft Shell Controls and Automation​
  Dim objShell As Shell​
  Set objShell = New Shell​
  objShell.controlPanelItem ("mmsys.cpl") 'Proprietes Sons Et Peripheriques Audio​
  'objShell.controlPanelItem ("desk.cpl")'fenetre Proprietes Affichage Windows​
  'objShell.controlPanelItem ("appwiz.cpl") 'fenetre Proprietes Sons Et Peripheriques Audio​
  'objShell.controlPanelItem ("timedate.cpl") 'fenetre Proprietes de dates et heures​
  'objShell.controlPanelItem ("sysdm.cpl") 'fenetre Proprietes systeme​
  'objShell.controlPanelItem ("main.cpl") 'fenetre Proprietes de la souris​
  'objShell.controlPanelItem ("intl.cpl") 'fenetre options regionales et linguistiques​
  'objShell.fileRun 'boite de dialogue Execution​
  End Sub​
• Afficher la boite de dialogue Observateur d'evenements
  
  Sub observateurEvenements()​
  Dim objShell As Object​
  Dim Machine As String​
  Dim retVal As Long​
  Machine = "."​
  Set objShell = createObject("wscript.shell")​
  retVal = objShell.Run("eventvwr.exe " & Machine & " C:\Windows\system32", 1, True)​
  End Sub​
• Ouvrir l'explorateur Windows sur un répertoire precis
  
  Sub ouvrirExplorateurWindows()​
  'necessite d'activer reference Microsoft Shell Controls and Automation​
  Dim objShell As Shell​
  Set objShell = New Shell​
  objShell.Explore ("C:\Documents and Settings\michel\dossier\general\excel")​
  End Sub​
• positionner le curseur de la souris à un endroit précis sur l'écran
  
  Declare Function SetCursorPos Lib "user32" _​
  (byVal x As Long, byVal y As Long) As Long​
  Sub positionCurseur()​
  SetCursorPos 100, 200​
  End Sub​
• Utiliser l'API getCursorPos pour récupérer la position du curseur de la souris à l'écran
  
  Le lien sur le forum XLD​
• Afficher le nom du PC
  
  Le lien sur le forum XLD​
• Récupérer quelques informations sur votre PC
  
  le nom du PC​
  le systeme utilisé​
  les noms et types de lecteurs ( avec le numéro de serie et l'espace libre pour les disques durs )​
  la résolution de l'écran​
  la mémoire physique totale et libre​
  la liste des imprimantes installées et l'imprimante active​
  la version d'Excel et de VBE​
  les processeurs​
  l'utilisateur​
  l'adresse IP​
  Le lien sur le forum XLD​
  Le fichier zippé​
• Afficher des informations sur un excecutable
  
  le nom de l'éditeur​
  la description du programme​
  la version du fichier​
  le nom interne​
  le copyright​
  le nom de l'application​
  le nom du produit​
  la version du produit​
  Le lien sur le forum XLD​
  Lien supprimé​
• Afficher la version d'une application
  
  Sub versionApplication()​
  Dim Fso As Object​
  Set Fso = createObject("Scripting.fileSystemObject")​
  msgBox Fso.getFileVersion("C:\WINDOWS\system32\calc.exe")​
  End Sub​
• Changer l'image de fond d'écran du bureau , depuis Excel
  
  Private Declare Function SystemParametersInfo Lib _​
  "user32" Alias "SystemParametersInfoA" _​
  (byVal uAction As Long, byVal uParam As Long, byVal lpvParam As Any, _​
  byVal fuWinIni As Long) As Long​
  Private Const SPI_SETDESKWALLPAPER = 20​
  Sub changerFondEcran()​
  'testé avec Excel2002 et WinXP​
  Dim retVal As Long​
  Dim Fichier As String​
  Fichier = "C:\WINDOWS\Plume.bmp" 'adapter le chemin du fichier​
  retVal = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Fichier, 0)​
  End Sub​
• Afficher la boite de dialogue pour régler le son du PC
  
  Sub reglageSonPC()​
  Dim retVal As Long​
  retVal = Shell("sndvol32 /t")​
  End Sub​
• Controler la présence d'une carte son sur le poste de travail
  
  Declare Function waveOutGetNumDevs Lib "winmm" () As Long​
  Sub controlePresenceCarteSon()​
  Dim i As Long​
  i = waveOutGetNumDevs()​
  If i > 0 Then msgBox "Il y a une carte son sur votre poste . "​
  End Sub​
• XLD Music Player , un lecteur de CD audio pour Excel , à partir de la version 2000
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Afficher la durée des fichiers WMV , AVI , WAV , MP3
  
  Le lien sur le forum XLD​
• Récupérer le ProcessID d'une fenetre spécifique
  
  Le lien sur le forum XLD​
• Enregistrer dans un fichier texte les propriétés des périphériques USB
  
  Sub listerProprietes_peripheriqueUsb()​
  'adapté de http://www.vbcode.com/%%% 'enregistre les proprietes des peripheriques USB​
  'dans un fichier Texte ( dans le meme repertoire que ce classeur )​
  'testé avec WinXP et Excel2002​
  Dim objWMIService As Object, objItem As Object, colItems As Object​
  Dim nomPC As String​
  Dim Fichier As String​
  nomPC = "."​
  Fichier = thisWorkbook.Path & "\Propriétés_USB.Txt"​
  Open Fichier For Output As #1​
  Set objWMIService = getObject("winmgmts:\\" & nomPC & "\root\cimv2")​
  Set colItems = objWMIService.execQuery("Select * from Win32_USBController", , 48)​
  For Each objItem In colItems​
  Print #1, ""​
  Print #1, "Availability: " & objItem.Availability​
  Print #1, "Caption: " & objItem.Caption​
  Print #1, "configManagerErrorCode: " & objItem.configManagerErrorCode​
  Print #1, "configManagerUserConfig: " & objItem.configManagerUserConfig​
  Print #1, "creationClassName: " & objItem.creationClassName​
  Print #1, "Description: " & objItem.Description​
  Print #1, "DeviceID: " & objItem.DeviceID​
  Print #1, "errorCleared: " & objItem.errorCleared​
  Print #1, "errorDescription: " & objItem.errorDescription​
  Print #1, "installDate: " & objItem.installDate​
  Print #1, "lastErrorCode: " & objItem.lastErrorCode​
  Print #1, "Manufacturer: " & objItem.Manufacturer​
  Print #1, "maxNumberControlled: " & objItem.maxNumberControlled​
  Print #1, "Name: " & objItem.Name​
  Print #1, "PNPDeviceID: " & objItem.PNPDeviceID​
  Print #1, "powerManagementCapabilities: " & objItem.powerManagementCapabilities​
  Print #1, "powerManagementSupported: " & objItem.powerManagementSupported​
  Print #1, "protocolSupported: " & objItem.protocolSupported​
  Print #1, "Status: " & objItem.Status​
  Print #1, "statusInfo: " & objItem.statusInfo​
  Print #1, "systemCreationClassName: " & objItem.systemCreationClassName​
  Print #1, "systemName: " & objItem.systemName​
  Print #1, "timeOfLastReset: " & objItem.timeOfLastReset​
  Print #1, ""​
  Print #1, ""​
  Next​
  Close​
  End Sub​
• Afficher certaines boites de dialogue du systeme d'exploitation, en utilisant le fonction Shell
  
  'Afficher le panneau de configuration​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus)​
  'Afficher la boite de dialogue des options régionales​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl")​
  'Afficher la boite de dialogue "propriétés de la souris"​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", vbNormalFocus)​
  'Afficher la boite de dialogue "propriétés d'affichage" Bureau​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", vbNormalFocus)​
  'Afficher la boite de dialogue "propriétés d'affichage" Ecran de veille​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", vbNormalFocus)​
  'Afficher la boite de dialogue "propriétés d'affichage" Apparence​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", vbNormalFocus)​
  'Afficher la boite de dialogue "propriétés d'affichage" Parametres​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", vbNormalFocus)​
  'Afficher la boite de dialogue Options d'accessibilité​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl", vbNormalFocus)​
  'Afficher la boite de dialogue Ajout et supression de programmes​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl", vbNormalFocus)​
  'Afficher la boite de dialogue Propriétés Internet​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl", vbNormalFocus)​
  'Afficher la boite de dialogue Controleur de jeux​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", vbNormalFocus)​
  'Afficher la boite de dialogue Propriétés du clavier​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", vbNormalFocus)​
  'Afficher la boite de dialogue Propriétés de sons et peripheriques audio​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl", vbNormalFocus)​
  'Afficher la boite de dialogue Options de modes et telephonie​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", vbNormalFocus)​
  'Propriétés du systeme​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl", vbNormalFocus)​
  'Propriétés de Date et Heure​
  Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", vbNormalFocus)​
• Récuperer le code couleur à l'emplacement du curseur de la souris
  
  Une des macros du classeur permet aussi de récupérer la couleur de fond du bureau​
  Le lien sur le forum XLD​
  Lien supprimé​
• Fermer Windows et redémarrer le PC
  
  une démo par EMG​
  Le lien sur le forum XLD​
  une démo par Veriland​
  Le lien sur le forum XLD​
  des infos complémentaires de @+Thierry pour Windows2000​
  Le lien sur le forum XLD​
• Creer un raccourci sur le bureau , pour le classeur contenant cette macro
  
  Sub creerRaccourciBureau()​
  'necessite d'activer la reference Windows Script Host Object Model​
  Dim xShell As IWshRuntimeLibrary.wshShell​
  Dim Raccourci As IWshRuntimeLibrary.wshShortcut​
  Dim dirBureau As String​
  Set xShell = createObject("WScript.Shell")​
  dirBureau = xShell.specialFolders("Desktop")​
  Set Raccourci = xShell.createShortcut(dirBureau & "\monFichier.lnk")​
  Raccourci.targetPath = thisWorkbook.fullName​
  Raccourci.windowStyle = 1​
  Raccourci.iconLocation = "C:\dating.ico" 'attribuer un icône​
  Raccourci.Save​
  End Sub​
• Vider le répertoire des documents recemment utilisés
  
  Declare Sub SHAddToRecentDocs Lib "shell32.dll" (byVal uFlags As Long, _​
  byVal pv As String)​
  Sub viderMenuDocumentsRecents()​
  'C:\Documents and Settings\michel\Recent​
  SHAddToRecentDocs 2, vbNullString​
  End Sub​
• Capturer les images perçues par une webCam
  
  Le lien sur le forum XLD​
  Lien supprimé​
  Un autre exemple qui permet de visionner ce que voit la webCam , en temps réel​
  Le lien sur le forum XLD​
  Lien supprimé​
• Lister des informations sur les raccourcis du bureau
  
  Le lien sur Internet​
• Boucler sur les raccourcis du bureau et le lancer si un nom est retrouvé
  
  (ACDSee.exe dans l'exemple )​
  Sub lancerRaccourciBureau()​
  'michelxld le 15.04.2005​
  'necessite d'activer la reference Microsoft Shell Controls and Automation​
  Const Cible = &H10 'Desktop​
  Dim objShell As Shell32.Shell​
  Dim objFolder As Shell32.Folder​
  Dim colItems As Shell32.folderItems​
  Dim objItem As Shell32.folderItem​
  Dim Longueur As Integer, i As Integer​
  Set objShell = createObject("Shell.Application")​
  Set objFolder = objShell.nameSpace(Cible)​
  Set colItems = objFolder.Items​
  For Each objItem In colItems​
  If objItem.isLink Then​
  Longueur = Len(objItem.getLink.Path)​
  i = Longueur​
  While Mid(objItem.getLink.Path, i, 1) <> "\"​
  i = i - 1​
  Wend​
  If Mid(objItem.getLink.Path, i + 1, Longueur - i) = "ACDSee.exe" _​
  Then objItem.invokeVerb​
  End If​
  Next​
  End Sub​
• Sélectionner des fichiers et les copier dans un autre répertoire
  
  Le lien sur le forum XLD​
• Créer un fichier Wave à partir d'Excel
  
  Le lien sur le forum XLD​
  Lien supprimé​
• Lister et afficher quelques informations sur les disques amovibles connectés au poste de travail
  
  Sub listeLecteursAmovible()​
  Dim FSO As Scripting.fileSystemObject​
  Dim Drv As Scripting.Drive​
  Set FSO = createObject("Scripting.fileSystemObject")​
  For Each Drv In FSO.Drives​
  If Drv.driveType = 1 Then _​
  msgBox "le support " & Drv.driveLetter & " est pret : " & Drv.isReady & vbLf _​
  & "espace libre : " & Format(Drv.freeSpace, "#,##0") & " octets "​
  Next​
  End Sub​
• Envoyer un fichier dans la corbeille
  
  Le lien sur le forum XLD​
• Afficher la taille des fichiers contenus dans la Corbeille
  
  Sub tailleElementsCorbeille()​
  Dim objShell As Object, objFolder As Object, colItems As Object, objItem As Object​
  Dim tailleGDO As String​
  Dim taille As Long, Resultat As Long​
  Const Cible = &HA&​
  Set objShell = createObject("Shell.Application")​
  Set objFolder = objShell.Namespace(Cible)​
  Set colItems = objFolder.Items​
  For Each objItem In colItems​
  tailleGDO = objFolder.getDetailsOf(objItem, 3)​
  Resultat = Resultat + CLng(Val(tailleGDO))​
  Next​
  msgBox Resultat & " kb"​
  End Sub​
• Lister les types de lecteurs du PC et verifier s'ils sont disponibles
  
  Sub listeLecteurs()​
  Dim FSO As Object, Drv As Object​
  Set FSO = createObject("Scripting.fileSystemObject")​
  For Each Drv In FSO.Drives​
  msgBox "le support " & Drv.driveLetter & " (" & _​
  typeLecteur(Drv.drivetype) & ") est pret : " & Drv.isReady​
  Next​
  End Sub​
  Function typeLecteur(Dv As Byte) As String​
  Select Case Dv​
  Case 0: typeLecteur = "inconnu"​
  Case 1: typeLecteur = "disque amovible"​
  Case 2: typeLecteur = "disque dur"​
  Case 3: typeLecteur = "disque réseau"​
  Case 4: typeLecteur = "CDRom"​
  Case 5: typeLecteur = "disque virtuel"​
  End Select​
  End Function​
• Récupérer le numéro de série des lecteurs ( clés USB comprises )
  
  Sub numerosSerieLecteurs()​
  Dim FSO As Object, Drv As Object​
  On Error Resume Next​
  Set FSO = createObject("Scripting.fileSystemObject")​
  For Each Drv In FSO.Drives​
  msgBox Drv.driveletter & vbLf & "numero de serie :" & _​
  Abs(FSO.getDrive(Drv.driveletter & ":").serialNumber)​
  Next​
  End Sub​
• La fonction Environ our récupérer des informations sur le systeme d'exploitation
  
  Dim i As Byte​
  For i = 1 To 50​
  Cells(i, 1) = Environ(i)​
  Next i​
• Récupérer le nom de l'ordinateur
  
  Le lien sur le forum XLD​
• Récupérer la date d'installation de Windows (testé avec WinXP)
  
  For Each i In _​
  getObject("winmgmts:{impersonationLevel=impersonate}").execQuery("Select installDate, currentTimeZone From Win32_operatingSystem")​
  With createObject("wbemScripting.SWbemDateTime")​
  .Value = i.installDate​
  msgBox dateAdd("n", -i.currentTimeZone, .getVarDate)​
  End With​
  Next​
• Lister tout les Patchs (Hotfixs) installés sur le poste
  
  Sub listePatchs()​
  Dim strComputer As String​
  Dim objWMIService As Object, objQuickFix As Object, colQuickFixes As Object​
  'Source : http://microsoft.supinfo.com/scripts/17341/​
  strComputer = "."​
  Set objWMIService = getObject("winmgmts:" _​
  & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")​
  Set colQuickFixes = objWMIService.execQuery("Select * from Win32_quickFixEngineering")​
  For Each objQuickFix In colQuickFixes​
  Debug.Print "Computer: " & objQuickFix.CSName​
  Debug.Print "Description: " & objQuickFix.Description​
  Debug.Print "Hot Fix ID: " & objQuickFix.hotFixID​
  Debug.Print "Installation Date: " & objQuickFix.installDate​
  Debug.Print "Installed By: " & objQuickFix.installedBy​
  Next​
  End Sub​
• Vérifier si vous etes l'administrateur du poste
  
  Private Declare Function IsNTAdmin Lib "advpack.dll" _​
  (byVal dwReserved As Long, byRef lpdwReserved As Long) As Long​
  Sub administrateurPC()​
  msgBox CBool(IsNTAdmin(byVal 0&, byVal 0&))​
  End Sub​
• Récupérer des informations sur les comptes utilisateurs
  
  Sub Win32_Account_testExcel()​
  Dim Fso As Object, Rapport As Object​
  Dim wmObj As Object, Test As Object​
  Dim Valeur As Object, Ws As Object​
  On Error Resume Next​
  Set Fso = createObject("Scripting.fileSystemObject")​
  Set Rapport = Fso.openTextFile("C:\rapport.txt", 2, True)​
  Set wmObj = getObject("winMgmts:{impersonationLevel=impersonate}")​
  Set Test = wmObj.execQuery("Select * from win32_Account")​
  For Each Valeur In Test​
  Rapport.writeLine ("Nom : " & Valeur.name)​
  Rapport.writeLine ("Description : " & Valeur.Description)​
  Rapport.writeLine ("Domaines : " & Valeur.Domain)​
  Rapport.writeLine ("SID : " & Valeur.SID)​
  Rapport.writeLine ("------------------------------")​
  Next​
  Set Ws = createObject("WScript.Shell")​
  activeWorkbook.followHyperlink Address:="C:\rapport.txt"​
  End Sub​
• Récupérer le nom du serveur en fonction de la lettre attribuée
  
  Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _​
  (byVal lpszLocalName As String, byVal lpszRemoteName As String, byRef cbRemoteName As Long) As Long​
  Sub equivalence_Lettre_nomServeur()​
  Dim Lettre As String​
  Dim remName As String * 255​
  remName = String$(255, Chr$(32))​
  Lettre = "J:"​
  WNetGetConnection Lettre, remName, 255​
  msgBox Trim(remName)​
  End Sub​
• Lister les commandes qui démarrent automatiquement lors de l'ouverture d'une session
  
  Sub listerCommandesDemarrage()​
  Dim strComputer As String​
  Dim objWMIService As Object, colStartupCommands As Object, objStartupCommand As Object​
  strComputer = "."​
  Set objWMIService = getObject("winmgmts:\\" & strComputer & "\root\cimv2")​
  Set colStartupCommands = objWMIService.execQuery("Select * from Win32_startupCommand")​
  For Each objStartupCommand In colStartupCommands​
  Debug.Print "Command: " & objStartupCommand.Command​
  Debug.Print "Description: " & objStartupCommand.Description​
  Debug.Print "Location: " & objStartupCommand.Location​
  Debug.Print "Name: " & objStartupCommand.Name​
  Debug.Print "User: " & objStartupCommand.User​
  Debug.Print "---------------"​
  Next​
  End Sub​
• Déterminer le statut des ports
  
  Sub listerStatutsPorts()​
  Dim Cmd As String​
  Dim retVal As Long​
  Cmd = Environ("COMSPEC") & " /C "​
  retVal = Shell(Cmd & "NETSTAT -na> C:\listePorts.txt")​
  doEvents​
  thisWorkbook.followHyperlink "C:\listePorts.txt"​
  End Sub​
• Lister les logiciels installés depuis Windows Installer
  
  Sub Test()​
  'source :​
  'Ce lien n'existe plus​
  Dim objWMIService As Object​
  Dim colSoftware As Object, objSoftware As Object​
  Dim strComputer As String​
  strComputer = "."​
  Set objWMIService = getObject("winmgmts:{impersonationLevel=impersonate}!\\" & _​
  strComputer & "\root\cimv2")​
  Set colSoftware = objWMIService.execQuery("Select * from Win32_Product")​
  For Each objSoftware In colSoftware​
  Debug.Print "Caption : " & objSoftware.Caption​
  Debug.Print "Description : " & objSoftware.Description​
  Debug.Print "identifyingNumber : " & objSoftware.identifyingNumber​
  Debug.Print "installDate2 : " & objSoftware.installDate2​
  Debug.Print "installLocation : " & objSoftware.installLocation​
  Debug.Print "installState : " & objSoftware.installState​
  Debug.Print "Name : " & objSoftware.Name​
  Debug.Print "packageCache : " & objSoftware.packageCache​
  Debug.Print "SKUNumber : " & objSoftware.SKUNumber​
  Debug.Print "Vendor : " & objSoftware.Vendor​
  Debug.Print "Version : " & objSoftware.Version​
  Debug.Print " "​
  Debug.Print "-----"​
  Next​
  End Sub​
• Lister les points de restauration de votre systeme (XP)
  
  Sub listerPointsDeRestauration()​
  Dim objWMIService As Object, colItems As Object, objItem As Object​
  Dim strComputer As String, strRestoreType As String​
  strComputer = "."​
  Set objWMIService = getObject("winmgmts:" _​
  & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\default")​
  Set colItems = objWMIService.execQuery("Select * from systemRestore")​
  If colItems.Count = 0 Then​
  Exit Sub​
  Else​
  For Each objItem In colItems​
  Debug.Print "Name: " & objItem.Description​
  Debug.Print "Number: " & objItem.sequenceNumber​
  Select Case objItem.restorePointType​
  Case 0: strRestoreType = "Application installation"​
  Case 1: strRestoreType = "Application uninstall"​
  Case 6: strRestoreType = "Restore"​
  Case 7: strRestoreType = "checkpoint"​
  Case 10: strRestoreType = "Device drive installation"​
  Case 11: strRestoreType = "First run"​
  Case 12: strRestoreType = "Modify settings"​
  Case 13: strRestoreType = "Cancelled operation"​
  Case 14: strRestoreType = "Backup recovery"​
  Case Else: strRestoreType = "Unknown"​
  End Select​
  Debug.Print "Restore Point Type: " & strRestoreType​
  Debug.Print "Time: " & objItem.creationTime​
  Debug.Print "---"​
  Next​
  End If​
  End Sub​

Piloter une animation Flash dans Excel

Ce lien n'existe plus​

Lien supprimé​

Les différents types de boucles

• For Each Next
  
  Cette instruction permet de boucler sur tous les éléments d'une collection .​
  Une collection peut etre :​
  l'ensemble des feuilles d'un classeur​
  l'ensemble des cellules d'une plage​
  l'ensemble des graphiques d'une feuille​
  ...etc…​
  Dans cet exemple , la procédure boucle sur toutes les cellules de la plage A1:A10 et affiche un message si le mot "XLD" est trouvé​
  Sub rechercheDansPlageCellules()​
  Dim Cell As Range​
  For Each Cell In Range("A1:A10")​
  If Cell = "XLD" Then​
  msgBox "trouvé ! "​
  Exit For​
  End If​
  Next Cell​
  End Sub​
  Remarque :​
  lorsque les temps de calculs sont longs , il peut etre utile de sortir avant la fin de la boucle , en utilisant l'instruction Exit For​
  (Dans l'exemple ci dessus , on sort de la boucle dès que le mot "XLD" est trouvé )​
• For To Step Next
  
  Permet de répéter une action , le nombre de fois défini par la boucle​
  Un exemple pour insérer des données dans la plage de cellules A1:A100​
  Sub Boucle01()​
  Dim i As Byte​
  For i = 1 To 100​
  Cells(i, 1) = "XLD" & i​
  Next i​
  End Sub​
  Remarque :​
  il est aussi possible d'utiliser l'instruction Exit For pour sortir de ce type de boucle​
  L'argument Step permet de définir la fréquence de l'action dans la boucle :​
  Par défaut , Step = 1 si l'argument n'est pas précisé .​
  le meme exemple que précédemment , mais en insérant des données dans 1 cellule sur 5 ( Step = 5 )​
  Sub Boucle02()​
  Dim i As Byte​
  For i = 1 To 100 Step 5​
  Cells(i, 1) = "XLD" & i​
  Next i​
  End Sub​
  L'argument Step peut aussi etre négatif ( Step = -1 )​
  Un exemple qui boucle sur la plage A1:A100 , en commençant par la dernière cellule , pour supprimer la ligne si la cellule est vide​
  Sub Boucle03()​
  Dim i As Integer​
  For i = 100 To 1 Step -1​
  If Cells(i, 1) = "" Then Rows(i).Delete​
  Next i​
  End Sub​
• Do Loop
  
  Dans ce premier exemple , la procédure boucle sur toutes les cellules de la plage A1:A10 et affiche un message si le mot "XLD" est trouvé​
  Sub Boucle04()​
  Dim i As Byte​
  Do While i < 10​
  i = i + 1​
  If Cells(i, 1) = "XLD" Then​
  msgBox "trouvé ! "​
  Exit Do​
  End If​
  Loop​
  End Sub​
  Remarque :​
  lorsque les temps de calculs sont longs , il peut etre utile de sortir avant la fin de la boucle , en utilisant l'instruction Exit Do​
  (Dans l'exemple ci dessus , on sort de la boucle dès que le mot recherché est trouvé )​
  Un autre exemple de boucle sur les cellules de la colonne A jusqu'à ce que la donnée "XLD" soit trouvée​
  utilisation de la condition Until ( jusqu'à ce que la cellule soit égale à "XLD" )​
  Sub Boucle05()​
  Dim i As Byte​
  Do​
  i = i + 1​
  If Cells(i, 1) = "XLD" Then​
  msgBox "trouvé ! "​
  End If​
  Loop Until Cells(i, 1) = "XLD"​
  End Sub​
  Le meme exemple , mais avec l'utilisation de la condition While ( boucle tant que la cellule est différente de "XLD" )​
  Sub Boucle06()​
  Dim i As Byte​
  Do​
  i = i + 1​
  If Cells(i, 1) = "XLD" Then​
  msgBox "trouvé ! "​
  End If​
  Loop While Cells(i, 1) <> "XLD"​
  End Sub​
  Attention , pour ces 2 derniers exemples il faut etre sur d'avoir au moins une cellule qui répond à la condition ="XLD" , sinon vous allez créer une boucle infinie.​
  Remarque :​
  Les macros présentées dans ce chapitre servent simplement à visualiser la logique de fonctionnement , pour les différents types de boucles .​
  Si vous souhaitez obtenir des exemples plus détaillés , ou d'autres méthodes de requète sans utiliser de boucle ( nottament pour effectuer des recherches dans les feuilles ) , consultez le chapitre "Les recherches dans un classeur" .​

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 15 Septembre 2006