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

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

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

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

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

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

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

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

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

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

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

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

Les 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

  Le fichier zippé

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

  Visualiser la macro

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.

  Visualiser 3 exemples de macros pour afficher ces fichiers d'aide

  Des informations complémentaires sur le site de Microsoft :

  http://support.microsoft.com/default.aspx?scid=kb%3Bfr%3B209843

  http://www.microsoft.com/technet/prodtechnol/office/office2000/solution/part2/ch13.mspx?mfr=true

  Parmi les outils de création disponibles , il existe HTML Help Workshop, téléchargeable sur le site Microsoft.

  http://msdn.microsoft.com/library/default.asp?url=/library/en-us/htmlhelp/html/hwMicrosoftHTMLHelpDownloads.asp

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.clearConten ts

  '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

  Le lien sur le forum XLD

• 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

  Visualiser la macro

• 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", "http://www.excel-downloads.com/templates/xld/images/logoessais.gif", 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

  Le fichier zippé

• Un autre exemple qui affiche un texte d'information dans une fenetre Internet Explorer

  Le fichier zippé

• 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

  Le fichier zippé

• 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("Favo rites") '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:="http://www.maPage.html")

  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

  Le fichier zippé

• Modifier une page Html par macro

  Le lien sur le forum XLD

  Le fichier zippé

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

  'http://www.excel-downloads.com/component/option,com_simpleboard/Itemid,40/func,view/catid,2/id,98119/#98119

  '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

  Visualiser la macro

• 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=impersonat e}!\\" _

  & 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

  Visualiser la macro

• Lister les paramètres de connection Internet

  Visualiser la macro

• Lister le sommaire des paramètres Internet Explorer

  Visualiser la macro

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é

  Visualiser la macro

• 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

  Le fichier zippé

• 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

  Le fichier zippé

• 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

  Le fichier zippé

• 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

  Le fichier zippé

  Un autre exemple qui permet de visionner ce que voit la webCam , en temps réel

  Le lien sur le forum XLD

  Le fichier zippé

• 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

  Le fichier zippé

• 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=impersonat e}").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=impersonat e}")

  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 :

  'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/win32_product.asp

  Dim objWMIService As Object

  Dim colSoftware As Object, objSoftware As Object

  Dim strComputer As String

  strComputer = "."

  Set objWMIService = getObject("winmgmts:{impersonationLevel=impersonat e}!\\" & _

  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

Afficher la page

Le fichier zippé

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