'----------------------------------------------------
'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

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 Excel 2002 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

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

'*********************
'Sources: https://support.microsoft.com/fr-fr/help/466935
'
'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

Sub versionApplication()
    Dim Fso As Object
 
    Set Fso = CreateObject("Scripting.fileSystemObject")
    MsgBox Fso.getFileVersion("C:\WINDOWS\system32\calc.exe")
End Sub

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

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

'Nom de l'utilisateur qui a ouvert la session Windows.
MsgBox Environ("USERNAME")

findandkillwindows 0,"*","IEFrame"

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

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

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

'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

'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

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

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

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

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

Sub MinimiserToutesLesApplications()
    Dim WSHshell As Object, Shell As Object
 
    Set WSHshell = CreateObject("WScript.Shell")
    Set Shell = CreateObject("Shell.Application")
 
    Shell.MinimizeAll
End Sub