[REF] Wiki Page 7 de MichelXld

MichelXld

XLDnaute Barbatruc
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 .​




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
    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
  • 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)
  • 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 :​
    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
  • 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
  • Télécharger une image web : utilisation des requètes winHttp
    Sub recupererImageWeb_winHttp()​
    '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​
    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
    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​
  • Afficher le nom d'une page internet
    Sub afficherNomPageInternet()​
    'activer la reference Microsoft Internet Controls​
    Dim IE As internetExplorer​
    Set IE = New internetExplorer​
    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​
    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​
    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​
    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()​
    '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​
    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 )
  • Piloter une liste de choix dans une page Web
  • Ouvrir une page IE en plein écran
  • 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
    Lien supprimé
  • Vérifier l'état de la connection au réseau
    Voir le message du 26/07/2005 10:41​
  • 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​
    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.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​
    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 )​
  • 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
  • Afficher le nom du PC
  • 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​
  • 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​
    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
    Lien supprimé
  • Afficher la durée des fichiers WMV , AVI , WAV , MP3
  • Récupérer le ProcessID d'une fenetre spécifique
  • 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​
    Lien supprimé
  • Fermer Windows et redémarrer le PC
    une démo par EMG​
    une démo par Veriland​
    des infos complémentaires de @+Thierry pour Windows2000​
  • 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
    Lien supprimé
    Un autre exemple qui permet de visionner ce que voit la webCam , en temps réel​
    Lien supprimé
  • Lister des informations sur les raccourcis du bureau
  • 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
  • Créer un fichier Wave à partir d'Excel
    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
  • 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 :pour 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
  • 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​
    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
 
Dernière modification par un modérateur:

Discussions similaires

Statistiques des forums

Discussions
311 540
Messages
2 080 529
Membres
101 234
dernier inscrit
Layani89