Developpez.com

Plus de 2 000 forums
et jusqu'à 5 000 nouveaux messages par jour

FAQ ExcelConsultez toutes les FAQ

Nombre d'auteurs : 46, nombre de questions : 845, dernière mise à jour : 30 mars 2017 

 
OuvrirSommaireLes macros VBALe PC et le système d'exploitation
Vba
Sélectionnez

'----------------------------------------------------
'Source:
'http://www.tek-tips.com/viewthread.cfm?qid=794484
'
'----------------------------------------------------
 
Private Declare Function NetScheduleJobAdd Lib "netapi32.dll" _
    (ByVal Servername As String, Buffer As Any, JobID As Long) As Long
 
 
Private Type AT_INFO
    JobTime As Long
    DaysOfMonth As Long
    DaysOfWeek As Byte
    Flags As Byte
    Command As String
End Type
 
 
Private Enum JobAdd
    JOB_RUN_PERIODICALLY = 1&
    JOB_ADD_CURRENT_DATE = 8&
    JOB_NONINTERACTIVE = 16&
End Enum
 
 
Private Enum sjWeekdays
    Monday = 1
    Tuesday = 2
    Wednesday = 4
    Thursday = 8
    Friday = 16
    Saturday = 32
    Sunday = 64
End Enum
 
 
Private Enum sjDays
    d1 = 1
    d2 = 2
    d3 = 4
    d4 = 8
    d5 = 16
    d6 = 32
    d7 = 64
    d8 = 128
    d9 = 256
    d10 = 512
    d11 = 1024
    d12 = 2048
    d13 = 4096
    d14 = 8192
    d15 = 16384
    d16 = 32768
    d17 = 65536
    d18 = 131072
    d19 = 262144
    d20 = 524288
    d21 = 1048576
    d22 = 2097152
    d23 = 4194304
    d24 = 8388608
    d25 = 16777216
    d26 = 33554432
    d27 = 67108864
    d28 = 134217728
    d29 = 268435456
    d30 = 536870912
    d31 = 1073741824
End Enum
 
 
 
Sub Test()
    '(ouverture du bloc notes)
    'Tache ponctuelle dans une minute (ouverture du bloc notes)
    vbScheduleJob "notepad.exe", DateAdd("n", 1, Now), JOB_ADD_CURRENT_DATE
 
    'vbScheduleJob "notepad.exe", DateAdd("n", 1, Now), JOB_RUN_PERIODICALLY, Wednesday, d4
End Sub
 
 
Private Function vbScheduleJob(strCommand As String, sjTime As Date, _
    AddFlags As JobAdd, Optional DayOfWeek As sjWeekdays = 0, _
    Optional DayOfMonth As sjDays = 0, Optional PCName As String = vbNullString) As Long
 
    Dim myInfo As AT_INFO
    Dim JobID As Long
 
    With myInfo
        .Command = StrConv(strCommand, vbUnicode)
        .Flags = AddFlags
        .JobTime = DateDiff("s", "00:00:00", Format(sjTime, "hh:mm:ss")) * 1000
        .DaysOfWeek = DayOfWeek
        .DaysOfMonth = DayOfMonth
    End With
 
    NetScheduleJobAdd PCName, myInfo, JobID
 
    vbScheduleJob = JobID
End Function
Créé le 19 février 2008  par SilkyRoad
Vba
Sélectionnez

Option Explicit
 
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()
    '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\nom_utilisateur\dossier\nomfichier.bmp"
    ShellExecute 0, "open", "rundll32.exe", _
        "C:\WINDOWS\System32\shimgvw.dll,ImageView_Fullscreen " & Img, 0, 1
End Sub
Créé le 19 février 2008  par SilkyRoad
Vba
Sélectionnez

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
Créé le 19 février 2008  par SilkyRoad

Utilisez la procédure "AfficherInformationsApplication" pour afficher la boîte de dialogue "Ouvrir".
Sélectionnez un fichier quelconque (ou directement un exécutable) puis cliquez sur le bouton "Ouvrir".

Le code va ensuite récupérer le nom de l'exécutable qui ouvre le fichier sélectionné et afficher des informations sur le programme, notamment:
     *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

Testé sous WinXP/Excel2007, WinXP/Excel2002 et Win98/Excel97.

Vba
Sélectionnez

'*********************
'Sources: http://support.microsoft.com/kb/466935/fr
'
'adapté pour une utilisation en VBA Excel
'*********************
 
Option Explicit
 
'lptstrFilename: adresse du nom de fichier
'dwHandle: handle d'information sur la version
'dwLen: taille du strBuffer contenant l'information
'lpData: adresse du premier octet du strBuffer contenant l'information
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias _
    "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwHandle As Long, _
    ByVal dwLen As Long, lpData As Any) As Long
 
'La fonction GetFileVersionInfoSize détermine si les informations sur la
'version existent. Si c'est le cas, cette fonction retourne la taille du
'strBuffer contenant l'information et le handle d'information que l'on
'passera à L'API GetFileVersionInfo. Cette dernière permet de récupérer
'les informations sur la version.
'lptstrFilename: adresse du nom de fichier
'lpdwHandle: adresse du handle d'information sur la version
Private Declare Function _
    GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" _
    (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
 
 
'La fonction VerQueryValue retourne la partie d'information sur la version:
    'lpvBlock: adresse du premier octet du strBuffer contenant l'information
    'lpszSubBlock: adresse de la partie de l'information qui nous intéresse
    'lplpstrBuffer: adresse du strBuffer contenant la valeur demandée
    'lpcb: adresse de la taille du strBuffer contenant la valeur demandée
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" _
    (pBlock As Any, ByVal lpSubBlock As String, lplpstrBuffer As Any, puLen As Long) As Long
 
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, _
    ByVal Source As Long, ByVal Length As Long)
 
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
    (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
 
Public Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, _
    ByVal lpdirectory As String, ByVal lpResult As String) As Long
 
Public Const MAX_FILENAME_LEN = 256
 
 
 
Function DescriptionAppli(ByVal Cible As String, ByVal Donnee As String) As String
 
    Dim s As String, strW As String, strBuffer As String, Lc As String
    Dim Rc As Long, x As Long, p As Long, j As Long, i As Long
    Dim byteTabBuffer(255) As Byte
    Dim TabBuffer() As Byte
 
    s = Donnee
 
    j = GetFileVersionInfoSize(Cible, i)
    If j < 1 Then Exit Function
 
    ReDim TabBuffer(j)
    Rc = GetFileVersionInfo(Cible, 0&, j, TabBuffer(0))
    If Rc = 0 Then
        DescriptionAppli = False
        Exit Function
    End If
 
    Rc = VerQueryValue(TabBuffer(0), "\VarFileInfo\Translation", p, j)
    If Rc = 0 Then Exit Function
 
    MoveMemory byteTabBuffer(0), p, j
 
    x = byteTabBuffer(2) + byteTabBuffer(3) * &H100 + byteTabBuffer(0) * _
        &H10000 + byteTabBuffer(1) * &H1000000
 
    Lc = Hex(x)
 
    Do While Len(Lc) < 8
        Lc = "0" & Lc
    Loop
 
    strBuffer = String(255, 0)
    strW = "\StringFileInfo\" & Lc & "\" & s
    Rc = VerQueryValue(TabBuffer(0), strW, p, j)
 
    If Rc = 0 Then Exit Function
 
    lstrcpy strBuffer, p
    strBuffer = Mid$(strBuffer, 1, InStr(strBuffer, Chr(0)) - 1)
 
    DescriptionAppli = strBuffer
End Function
 
 
Function FindExecutable(s As String) As String
    Dim i As Integer
    Dim S2 As String
 
    S2 = String(MAX_FILENAME_LEN, 32) & Chr$(0)
    i = FindExecutableA(s & Chr$(0), vbNullString, S2)
 
    If i > 32 Then
        FindExecutable = Left$(S2, InStr(S2, Chr$(0)) - 1)
        Else
        FindExecutable = ""
    End If
End Function
 
 
 
Sub AfficherInformationsApplication()
    Dim Resultat As String, MonAppli As String, LeFichier As String
    Dim x As Variant, Tableau As Variant
    Dim i As Integer
 
    Tableau = Array("Comments", "CompanyName", "FileDescription", "FileVersion", _
        "InternalName", "LegalCopyright", "LegalTrademarks", "PrivateBuild", _
        "OriginalFileName", "ProductName", "productVersion", "SpecialBuild")
 
    x = Application.GetOpenFilename
    If x = False Then Exit Sub
 
    LeFichier = x
    MonAppli = FindExecutable(LeFichier)
 
    For i = LBound(Tableau) To UBound(Tableau)
        Resultat = Resultat & Tableau(i) & " :  " & _
        DescriptionAppli(MonAppli, Tableau(i)) & vbLf
    Next i
 
    MsgBox Resultat, , "Informations : " & MonAppli
End Sub




Vous pouvez aussi récupérer la version d'une application en utilisant la bibliothèque Microsoft Scripting Runtime:

Vba
Sélectionnez

Sub versionApplication()
    Dim Fso As Object
 
    Set Fso = CreateObject("Scripting.fileSystemObject")
    MsgBox Fso.getFileVersion("C:\WINDOWS\system32\calc.exe")
End Sub
Créé le 19 février 2008  par Microsoft, SilkyRoad
Vba
Sélectionnez

Sub SystemeExploitation()
    Dim WmObj As Object, Cible As Object
    Dim Obj As Object
 
    Set WmObj = GetObject("WinMgmts:{impersonationLevel=impersonate}")
    Set Cible = WmObj.ExecQuery("Select * from Win32_OperatingSystem")
 
    For Each Obj In Cible
        MsgBox Left(Obj.Name, InStr(1, Obj.Name, "|") - 1) & _
            vbCrLf & Obj.Version
    Next
End Sub
Créé le 19 février 2008  par SilkyRoad

La fonction Environ Renvoie des informations sur le système d'exploitation.

ALLUSERSPROFILE (Répertoire commun à tous les utilisateurs)
APPDATA (Répertoire Application Data)
CLIENTNAME
CommonProgramFiles (Répertoire des Fichiers communs)
COMPUTERNAME (Nom du PC)
ComSpec
FP_NO_HOST_CHECK
HOMEDRIVE
HOMEPATH
LOGONSERVER
NUMBER_OF_PROCESSORS
OS
Path
PATHEXT
PROCESSOR_ARCHITECTURE
PROCESSOR_IDENTIFIER
PROCESSOR_LEVEL
PROCESSOR_REVISION
ProgramFiles (Répertoire Program Files)
SESSIONNAME
SystemDrive
SystemRoot
TEMP(Répertoire Temp)
TMP
USERDOMAIN
USERNAME (Nom utilisateur connecté à la session)
USERPROFILE
WecVersionForRosebud.5C4
windir (Répertoire WINDOWS)

Vous pouvez boucler sur les variables d'environnement pour récupérer les données:

Vba
Sélectionnez

Dim i As Integer
 
For i = 1 To 30
    Cells(i, 1) = Environ(i)
Next i



Ou lire une variable spécifique:

Vba
Sélectionnez

'Nom de l'utilisateur qui a ouvert la session Windows.
MsgBox Environ("USERNAME")
Créé le 19 février 2008  par SilkyRoad

Cette procédure permet d'énumérer des fenêtres et de les fermer s'ils correspondent à la recherche générique de titre ou de classe.


Quelques exemples d'utilisation :
Fermer toutes les fenêtres Internet Explorer.

Vba
Sélectionnez

findandkillwindows 0,"*","IEFrame"



Fermer tous les fichiers notepad.

Vba
Sélectionnez

findandkillwindows 0, "*Bloc-note*","*"




Vba
Sélectionnez

Option Explicit
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long
 
Private Declare Function GetWindow Lib "user32" _
  (ByVal hWnd As Long, _
   ByVal wCmd As Long) As Long
 
Private Declare Function GetWindowText Lib "user32" _
   Alias "GetWindowTextA" _
  (ByVal hWnd As Long, _
   ByVal lpString As String, _
   ByVal cch As Long) As Long
 
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
   Alias "GetClassNameA" _
  (ByVal hWnd As Long, _
   ByVal lpClassName As String, _
   ByVal nMaxCount As Long) As Long
 
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Private Const WM_CLOSE = &H10
 
Public Sub FindAndKillWindows(ByVal hWndStart As Long, _
                              ByVal WindowText As String, _
                              ByVal ClassName As String)
 
   Dim hWnd As Long
   Dim sWindowText As String
   Dim sClassname As String
   Dim r As Long
 
   Static level As Integer
 
 
   If level = 0 Then
      If hWndStart = 0 Then hWndStart = GetDesktopWindow()
   End If
 
   level = level + 1
 
   hWnd = GetWindow(hWndStart, GW_CHILD)
 
   Do Until hWnd = 0
 
      FindAndKillWindows hWnd, WindowText, ClassName
 
      sWindowText = Space$(255)
      r = GetWindowText(hWnd, sWindowText, 255)
      sWindowText = Left(sWindowText, r)
 
      sClassname = Space$(255)
      r = GetClassName(hWnd, sClassname, 255)
      sClassname = Left(sClassname, r)
 
      If (sWindowText Like WindowText) And _
         (sClassname Like ClassName) Then
        Debug.Print "Fermeture de " & hWnd, "titre : " & sWindowText, "class : " & sClassname
         ' Ferme le window
         FermeUnWindow hWnd
 
      End If
 
      hWnd = GetWindow(hWnd, GW_HWNDNEXT)
 
   Loop
 
   level = level - 1
 
End Sub
 
 
Private Sub FermeUnWindow(ByVal hWnd As Long)
 
    PostMessage hWnd, WM_CLOSE, 0, 0 'ferme un window
 
End Sub
Créé le 26 mai 2008  par Cafeine

Cette méthode utilise la classe WMI MicrosoftIE_Summary.
Testé avec WinXP et IE.6

Vba
Sélectionnez

Sub ResumeProprietes_InternetExplorer()
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_Summary")
 
For Each strIESetting In colIESettings
    Debug.Print "Active printer: " & strIESetting.ActivePrinter
    Debug.Print "Build: " & strIESetting.Build
    Debug.Print "Cipher strength: " & strIESetting.CipherStrength
    Debug.Print "Content advisor: " & strIESetting.ContentAdvisor
    Debug.Print "IE Administration Kit installed: " & _
        strIESetting.IEAKInstall
    Debug.Print "Language: " & strIESetting.Language
    Debug.Print "Name: " & strIESetting.Name
    Debug.Print "Path: " & strIESetting.Path
    Debug.Print "Product ID: " & strIESetting.ProductID
    Debug.Print "Version: " & strIESetting.Version
    Debug.Print "---"
Next
End Sub
Créé le 20 septembre 2008  par SilkyRoad

Vous sélectionnez un fichier sur votre disque et la fonction va extraire l'icône de l'application correspondant.
Ce code nécessite d'activer la référence "Standard OLE Types".

Vba
Sélectionnez

'Dans un module standard
Option Explicit
 
Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
        (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, _
        ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
 
Public Declare Function OleCreatePictureIndirect _
        Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
        ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 
Public 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
 
Public Type PicBmp
   Size As Long
   tType As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type
 
Public Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type
 
Public Type SHFILEINFO
    hicon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * 260
    szTypeName As String * 80
End Type
 
 
Public Function GetIconFromFile(FileName As String, IconIndex As Long, _
        UseLargeIcon As Boolean) As IPicture
    '**************************************************************
    'Necessite d'activer la reference "Standard OLE Types"
    '**************************************************************
    Dim b As SHFILEINFO
    Dim retval As Long
    Dim pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
 
    retval = SHGetFileInfo(FileName, 0, b, Len(b), &H100)
 
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
 
    With pic
        .Size = Len(b)
        .tType = 3 'vbPicTypeIcon
        .hBmp = b.hicon
    End With
 
    Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
    Set GetIconFromFile = IPic
End Function
Vba
Sélectionnez

'Dans un UserForm qui contient 
'Un contrôle image nommé Image1
'Un contrôle CommandButton nommé CommandButton1
 
Private Sub CommandButton1_Click()
    Dim Fichier As String
 
    'Affiche la boîte de dialogue "Ouvrir"
    Fichier = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
    If Fichier = "" Then Exit Sub
 
    Set Image1.Picture = GetIconFromFile(Fichier, 1, True)
End Sub
Créé le 18 novembre 2008  par SilkyRoad
Vba
Sélectionnez

Option Explicit
 
Public 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 Ouvrir()
    Dim Fichier As String
 
    Fichier = "C:\dossier\nom image.jpg"
    ShellExecute 0, "", Fichier, "", "", 0
End Sub
Créé le 22 mars 2009  par Ouskelnor

Cette procédure permet de récupérer le nom du serveur, à partir de la lettre attribuée sur le réseau.

Vba
Sélectionnez

Option Explicit
 
Declare Function WNetGetConnection Lib "mpr.dll" Alias _
    "WNetGetConnectionA" (ByVal lpszLocalName As String, _
    ByVal lpszRemoteName As String, ByRef cbRemoteName As Long) As Long
 
 
Sub Test()
    Dim Lettre As String
    Dim Cible As String * 255
 
    Cible = String$(255, Chr$(32))
    Lettre = "W:"
    WNetGetConnection Lettre, Cible, 255
 
    MsgBox Trim(Cible)
End Sub




Cet autre exemple permet d'obtenir l'adresse UNC du classeur actif :

Vba
Sélectionnez

MsgBox Application.CommandBars.FindControl(ID:=1740).Text




Ce dernier exemple liste les répertoires en réseau et retrouve leur nom UNC :

Vba
Sélectionnez

Sub listerUNCPath()
    Dim wNwk As Object, oDrives As Object
    Dim i As Integer
 
    Set wNwk = CreateObject("WScript.Network")
    Set oDrives = wNwk.EnumNetworkDrives
 
    For i = 0 To oDrives.Count - 1 Step 2
        Debug.Print oDrives.Item(i) & " - " & oDrives.Item(i + 1)
    Next
End Sub
Créé le 22 mars 2009  par SilkyRoad

La procédure suivante permet de retourner sur le bureau en minimisant toutes les applications ouvertes.

Vba
Sélectionnez

Sub MinimiserToutesLesApplications()
    Dim WSHshell As Object, Shell As Object
 
    Set WSHshell = CreateObject("WScript.Shell")
    Set Shell = CreateObject("Shell.Application")
 
    Shell.MinimizeAll
End Sub
Créé le 22 mars 2009  par SilkyRoad
  

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2009 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.