Le PC , les autres applications et Windows

[MichelXld]

Bonjour

Vous trouverez ci dessous quelques exemples d'informations sur le PC , le systeme d'exploitation et les autres applications , depuis Excel
cela n'a plus grand chose à voir avec notre tableur préféré , mais c'est juste pour marquer mon 300 ieme message sur le nouveau forum XLD...;o)
( testé avec Excel2002 & WinXP)



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 ouvertes

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 ouvertes

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 fenetre 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 précis

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
Le lien sur le forum XLD
Lien supprimé



Afficher la vitesse paramétrée pour le double clic de la souris

Declare Function GetDoubleClickTime& Lib 'user32' ()
Sub tempsDoubleClic()
MsgBox GetDoubleClickTime & ' millisecondes .'
End Sub

Afficher le nom du PC

Le lien sur le forum XLD
Lien supprimé



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
Lien supprimé
Le fichier zippé
Lien supprimé



Afficher des informations sur un excecutable

le nom de l'éditeur
la description du programme
la version du fichier
le nom interne
le copyright
le nom de l'application
le nom du produit
la version du produit

Le lien sur le forum XLD
Lien supprimé
Le fichier zippé
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 PC

Declare Function waveOutGetNumDevs Lib 'winmm' () As Long

Sub controlePresenceCarteSon()
Dim i As Long
i = waveOutGetNumDevs()
If i > 0 Then msgBox 'Il y a une carte son sur votre poste . '
End Sub

XLD Music Player , un lecteur de CD audio pour Excel , à partir de la version 2000

Le lien sur le forum XLD
Lien supprimé
Le fichier zippé
Lien supprimé



Afficher la durée des fichiers WMV , AVI , WAV , MP3

Le lien sur le forum XLD
Lien supprimé



Enregistrer dans un fichier texte les propriétés des périphériques USB

Sub listerProprietes_peripheriqueUsb()
'adapté de  [url]http://www.vbcode.com/[/url] 
'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 la boite de dialogue des options régionales

Sub optionsRegionales()
Dim X As Double
X = Shell('rundll32.exe shell32.dll,Control_RunDLL intl.cpl')
End Sub

Afficher la boite de dialogue 'propriétés de la souris'

Sub proprietesSouris()
Call Shell('rundll32.exe shell32.dll,Control_RunDLL main.cpl @0', vbNormalFocus)
End Sub

Afficher la boite de dialogue 'propriétés d'affichage'

Sub propietesAffichage()
Call Shell('rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0', vbNormalFocus)
End Sub

Récuperer le code couleur à l'emplacement du curseur de la souris

Une des macros du classeur permet aussi de récupérer la couleur de fond du bureau
Le lien sur le forum XLD
Lien supprimé
Le fichier zippé
Lien supprimé



Fermer Windows et redémarrer le PC

Le lien sur le forum XLD (une démo par EMG)
Lien supprimé
Le lien sur le forum XLD (une démo par Veriland)
Lien supprimé
Le lien sur le forum XLD (des infos de @+Thierry pour Windows2000)
Lien supprimé



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 récemment utilisés

Declare Sub SHAddToRecentDocs Lib 'shell32.dll' (byVal uFlags As Long, _
byVal pv As String)

Sub viderMenuDocumentsRecents()
'C:\\Documents and Settings\\mimi\\Recent
SHAddToRecentDocs 2, vbNullString
End Sub

Capturer les images perçues par une webCam

Le lien sur le forum XLD
Lien supprimé
Le fichier zippé
Lien supprimé



Lister des informations sur les raccourcis du bureau

Sub informationsRaccourcisBureau()
'http://www.excelforum.com/showthread.php?p=932077&posted=1#post932077
'michelxld le 01.04.2005
'
'activate Microsoft Shell Controls and Automation reference
'activate Microsoft Scripting Runtime reference
'
'test with excel2002 & WinXp
Const Cible = &H10 'Desktop
'Const Cible = &H6 'Favorites
'
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim colItems As Shell32.FolderItems
Dim objItem As Shell32.FolderItem
Dim i As Integer
Dim Fso As Scripting.FileSystemObject
Dim FileItem As Scripting.File

Set objShell = CreateObject('Shell.Application')
Set objFolder = objShell.NameSpace(Cible)
Set colItems = objFolder.Items
Set Fso = CreateObject('Scripting.FileSystemObject')

For Each objItem In colItems
If objItem.IsLink Then
i = i + 1
Cells(i, 1) = objItem.Path
Cells(i, 2) = objItem.GetLink.Path
Cells(i, 3) = objFolder.GetDetailsOf(objItem, 14)

If Fso.FileExists(objItem.GetLink.Path) Then
Set FileItem = Fso.GetFile(objItem.GetLink.Path)
Cells(i, 4) = FileItem.Type
Cells(i, 5) = objItem.Name
End If

End If
Next
End Sub

Boucler sur les raccourcis du bureau et le lancer si le 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

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

Declare Function ShellExecute Lib 'shell32.dll' Alias 'ShellExecuteA' _
(ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub afficherImage_ApercuWindows()
'http://www.excel-downloads.com/html/French/forum/messages/1_127361_127361.htm
'testé avec Excel2002 et WinXP
'force l'affichage de l'image avec 'L'aperçu des images et des télécopies windows'.
Dim Img As String
Img = 'C:\\Documents and Settings\\michel\\dossier\\general\\general\\LeChat.bmp' 'adapter le chemin
ShellExecute 0, 'open', 'rundll32.exe', 'C:\\WINDOWS\\System32\\shimgvw.dll,ImageView_Fullscreen ' & Img, 0, 1
End Sub

Quatre méthodes pour ouvrir d'autres types de fichiers depuis Excel

Sub lancerPPT()
Dim Cible
Cible = Shell('POWERPNT.EXE ''C:\\Mes documents\\flux prod maint compta.ppt''', 1)
End Sub

Sub ouvrirWord()
thisWorkbook.followHyperlink 'C:\\Documents and Settings\\michel\\test.doc'
End Sub

Sub ouvertureAppli04()
Dim Obj As Object
Set Obj = createObject('WScript.Shell')
Obj.Run 'calc.exe ', 1, True'exemple calculatrice
End Sub

Declare Function WinExec Lib 'kernel32' (ByVal lpCmdLine As String, _
ByVal nCmdShow As Long) As Long
Sub OuvertureCalc()
WinExec 'calc', 10
End Sub

Lire un fichier directement avec l'application qui l'ouvre par défaut

Declare Function ShellExecute Lib 'shell32.dll' Alias 'ShellExecuteA' _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub ouvrirFichier()
'permet d'ouvrir un document avec l'executable défini par defaut
Dim leFichier As String
leFichier = 'C:\\Documents and Settings\\michel\\monDocumentOOo.sxw'
ShellExecute 0, 'open', leFichier, '', '', vbNormalFocus
End Sub

Fermer une application , Exemple notePad

Sub fermerUneApplication()
'testé avec Excel2002 et WinXP
Dim objProcess As Object, colProcessList As Object, objWMIService As Object
Dim strComputer As String
strComputer = '.'
Set objWMIService = getObject('winmgmts:' _
& '{impersonationLevel=impersonate}!\\\\' & strComputer & '\\root\\cimv2')
Set colProcessList = objWMIService.execQuery _
('Select * from Win32_Process Where Name = 'Notepad.exe'')
For Each objProcess In colProcessList
objProcess.Terminate
Next
End Sub

Lire un texte saisi dans un Userform

( utilisation de la librairie Microsoft Speech)

Le lien sur le forum XLD
Lien supprimé
Le fichier zippé
Lien supprimé

Il est aussi possible de modifier le ton lors de la diction
en ajoutant à la suite du texte : un espace et 2 points d'exclamations ' !!'
en ajoutant à la suite du texte : un espace et 2 points d'interrogation ' ??'




Lister le nom des fichiers contenus dans un Zip

Le lien sur le forum XLD
Lien supprimé
La source VB
http://www.vbfrance.com/code.aspx?id=17052



générer des fichiers Flash depuis Excel

(necessite d'installer prealablement la DLL Mingx )
http://www.swfkit.com/mingx/download.html
Le lien sur le forum XLD
Lien supprimé
Le fichier zippé
Lien supprimé




bon apres midi
MichelXld

 

[Hervé]

Bonjour

WAOUH, michel c'est sur que je vais passer un bon après midi, avec tout ce que tu nous donnes à 'digérer' comme code

Merci bien pour ces posts remplacant avantageusement l'aide d'excel.

Salut

 

[Eric C]

Bonjour le forum
Bonjour Michel, bonjour Hervé

Que de bonheur, j'espère que tu vas placer cette suite dans ta page Wiki pour que je puisse la retrouver d'un coup de 'favoris'.
Sinon, elle sera plaçée en lieu sûr avec tous mes trésors découverts sur ce fabuleux site.
Bonne fin de dimanche 😉

 

[michel_m]

Bonjour,

Encore une fois félicitations et Merci pour toutes tes démos: des tas de procédures que je croyais impossible à réaliser... en + utiles: j'ai utilisé la proc sur le PC dernièrement.

je rejoins Eric pour te demander de mettre tout çà sur le Wiki et comme Eric l'a fait, je vais mettre le Wiki en favori;

Bonne soirée et encore une fois Merci

Michel

 

[myDearFriend!]

Bravo MichelXLD !

Des liens comme celui-ci, ou comme ceux-là :
[ol][ul][li]Lien supprimé[/li]
[li]Lien supprimé[/li]
[li]Lien supprimé[/li]
[li]Lien supprimé[/li][/ul][/ol]
C'est du bonheur à lire, à tester et à consommer sans aucune modération !!!!
Merci, merci Michel, moi je suis fan !

Avec du boulot comme ça, j'implore David de bien vouloir inaugurer les News et te permettre un accès unique et spécial pour ces merveilles...


Message édité par: myDearFriend!, à: 24/04/2005 23:26

 

[dg62]

Bonjour le fil et merci Michel.


Une boîte à outils à garder sous la main.

 

[Dan]

Bonjour Michel, le forum,

Rien à dire !!!!, c'est de nouveau parfait et heureusement MyDearFriend a bien complété ton fil en y insérant ceux du passé.

Bravo.

:woohoo:

Message édité par: Dan, à: 25/04/2005 20:06

 

[Temjeh]

Merci à tous un post à mettre dans mon coffre-fort

Temjeh