XL 2019 Liste des fenêtres ouvertes

Aimedjie

XLDnaute Occasionnel
Bonjour,

J'aimerais avoir une macro qui dresse sur une feuille Excel la liste de toutes les fenêtres ouvertes pendant l'utilisation du fichier. Je sais que c'est possible, car j'ai vu beaucoup de discussions sur le sujet, mais jamais avec la liste qui s'écrit sur une feuille Excel. Bref, je donne des examens Excel en ligne et je veux savoir si mes étudiants trichent.

Merci!
 

Aimedjie

XLDnaute Occasionnel
Merci youky (BJ),

La macro fonctionne très bien. Par contre, je me suis peut-être mal exprimé. Je ne veux pas connaître les feuilles de mon classeur, mais plutôt toutes les applications Windows (PowerPoint, Chrome, Messenger, etc.)

Je veux voir si la réponse vient d'eux ou d'une quelconque aide externe.

Merci!
 

Lolote83

XLDnaute Accro
Bonjour à tous,
J'ai déterré un ancien fichier qui fonctionnait bien sous Excel 32 bits mais plus avec Excel 64 bits.
Je le livre donc tel quel en espérant que cela fonctionne chez toi et que cela corresponde à tes attentes.
PS : Si quelqu'un arrive à le faire fonctionner avec Excel 64 bits ????
Cordialement
Lolote83
 

Pièces jointes

  • ListeAppliOuvertes.xlsm
    23.2 KB · Affichages: 12

Rhysand

XLDnaute Junior
Bonjour à tous

essayez ce code
testé sur 32 et 64

pour effectuer la procédure, il suffit d'insérer Call getAppList



VB:
Private Declare PtrSafe Function apiGetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassname As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
Private Declare PtrSafe Function apiGetWindow Lib "user32" Alias "GetWindow" (ByVal Hwnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function apiGetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiGetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal aint As Long) As Long

Private Const mcGWCHILD = 5
Private Const mcGWHWNDNEXT = 2
Private Const mcGWLSTYLE = (-16)
Private Const mcWSVISIBLE = &H10000000
Private Const mconMAXLEN = 255
 
Public Sub getAppList()

Dim xStr As String, xHandleStr As String
Dim xStrLen As Long, xHandle As Long, xHandleLen As Long, xHandleStyle As Long
Dim ArrInput() As String
Dim x As Integer, i As Integer
Dim ArrOutput As Variant

If Not WorksheetExists("listApp") Then
    On Error Resume Next
    Worksheets.Add.Name = "listApp"
    On Error GoTo 0
End If

With Application.ThisWorkbook.Worksheets("listApp")
    .Cells.Clear
    With .Range("A1")
        .Value = "file/process name"
        .Interior.Color = VBA.RGB(128, 128, 128)
        .Font.ThemeFont = xlThemeFontMajor
        .Font.FontStyle = "Bold Italic"
        .Font.Name = "Arial"
    End With
    With .Range("B1")
        .Value = "app name"
        .Interior.Color = VBA.RGB(128, 128, 128)
        .Font.FontStyle = "Bold Italic"
        .Font.Name = "Arial"
        .Font.ThemeFont = xlThemeFontMajor
    End With
    .Range("A2").Activate
End With

i = 0

On Error Resume Next
ReDim ArrInput(0)
On Error GoTo 0

xHandle = apiGetWindow(apiGetDesktopWindow(), mcGWCHILD)

Do While xHandle <> 0
    xStr = VBA.String$(mconMAXLEN - 1, 0)
    xStrLen = apiGetWindowText(xHandle, xStr, mconMAXLEN)
    If xStrLen > 0 Then
        xStr = VBA.Left$(xStr, xStrLen)
        xHandleStyle = apiGetWindowLong(xHandle, mcGWLSTYLE)
        If xHandleStyle And mcWSVISIBLE Then
            ArrInput(i) = xStr
            i = i + 1
            ReDim Preserve ArrInput(i)
        End If
    End If
    xHandle = apiGetWindow(xHandle, mcGWHWNDNEXT)
Loop

If i > 0 Then
    For x = LBound(ArrInput) To UBound(ArrInput)
        ArrOutput = Split((ArrInput(x)), "-")
        On Error Resume Next
        ActiveCell.Value = ArrOutput(0)
        ActiveCell.Offset(0, 1) = VBA.Right(ArrInput(x), VBA.Len(ArrInput(x)) - getLastOcurrence(ArrInput(x), "-") + 1)
        On Error GoTo 0
        ActiveCell.Offset(1, 0).Activate
    Next x
End If

ActiveSheet.Columns.AutoFit
ActiveSheet.Rows.WrapText = False

End Sub

Function getLastOcurrence(xStr As String, xChar As String)

Dim xLen As Integer, i As Long
xLen = VBA.Len(xStr)

For i = xLen To 1 Step -1
    If VBA.Mid(xStr, i - 1, 1) = xChar Then
        getLastOcurrence = i
        Exit Function
    End If
Next i

End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

On Error Resume Next
WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
On Error GoTo 0

End Function


J'espère aider
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir @Aimedjie :)
et je veux savoir si mes étudiants trichent.
Il trichent ou bien sont ils simplement futés ?
Et quand bien même auraient ils ouvert une autre application : comment savoir ce qu'ils ont fait avec cette appli ?
Et si ce sont des tricheurs patentés, ils vont vite savoir comment ouvrir votre fichier sans activer les macros et vous le rendre aussi propre qu'un sou neuf.
Est ce légal d'implanter un mouchard à l'insu des étudiants pour connaitre leur activités sur leur PC ? J'en doute fort. Ça s'apparente à de l'espionnage/ piratage/vol de données/intrusion dans la vie privée. Attention, ça pourrait très vite se retourner contre vous. Je ne m'y risquerai pas.
 
Dernière édition:

Aimedjie

XLDnaute Occasionnel
Bonsoir @Aimedjie :)

Il trichent ou bien sont ils simplement futés ?
Et quand bien même auraient ils ouvert une autre application : comment savoir ce qu'ils ont fait avec cette appli ?
Et si ce sont des tricheurs patentés, ils vont vite savoir comment ouvrir votre fichier sans activer les macros et vous le rendre aussi propre qu'un sou neuf.
Est ce légal d'implanter un mouchard à l'insu des étudiants pour connaitre leur activités sur leur PC ? J'en doute fort. Ça s'apparente à de l'espionnage/ piratage/vol de données/intrusion dans la vie privée. Attention, ça pourrait très vite se retourner contre vous. Je ne m'y risquerai pas.

Bonsoir @mapomme,

Il ne s'agit pas d'un mouchard à l'insu des étudiants puisqu'ils sont avisés. Il ne s'agit pas d'espionnage / piratage / vol de données / intrusion dans la vie privée, mais plutôt valider s'ils respectent les consignes. Donc aucune cachette, ils sont avisés que pendant l'examen, les applis ouvertes seront notées dans le fichier Excel.
 

Aimedjie

XLDnaute Occasionnel
@Rhysand !!!!!!!!

Oh! que c'est merveilleux!!!!!!! C'est en plein ce que je cherchais. Je callg getAppList à l'ouverture, mais est-ce possible que les applis qui s'ouvrent pendant que le fichier est ouvert s'ajoutent à la liste ?

Bref, avoir sur la même feuille Excel la liste de toutes les applications qui étaient ouvertes pendant que le fichier Excel était ouvert ?

Merci encore!
 

Rhysand

XLDnaute Junior
Bonjour à tous

c'est à vous de décider où placer le "Call" pour démarrer les macros, je laisse un petit changement ici


VB:
Private Declare PtrSafe Function apiGetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassname As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
Private Declare PtrSafe Function apiGetWindow Lib "user32" Alias "GetWindow" (ByVal Hwnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function apiGetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiGetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal aint As Long) As Long

Private Const mcGWCHILD = 5
Private Const mcGWHWNDNEXT = 2
Private Const mcGWLSTYLE = (-16)
Private Const mcWSVISIBLE = &H10000000
Private Const mconMAXLEN = 255
 
Public Sub getAppList()

Dim xStr As String, xHandleStr As String, ComputerName, UserName As String, UnlockSheet As String
Dim xStrLen As Long, xHandle As Long, xHandleLen As Long, xHandleStyle As Long
Dim ArrInput() As String
Dim x As Integer, i As Integer, lastrow As Integer
Dim ArrOutput As Variant

If Not WorksheetExists("listApp") Then
    On Error Resume Next
    Worksheets.Add.Name = "listApp"
    On Error GoTo 0
End If

UnlockSheet = GetPassword(UnlockSheet)
Debug.Print UnlockSheet

ComputerName = VBA.Environ("computername")
Debug.Print ComputerName

UserName = VBA.Environ("username")
Debug.Print UserName

Application.ScreenUpdating = False

With Application.ThisWorkbook.Worksheets("listApp")
    .Visible = xlSheetVisible
    .Unprotect UnlockSheet
    .Select
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    If .Range("A1") = "" Then
        .Range("A1") = ComputerName
        .Range("B1") = UserName
        .Range("C1") = VBA.FormatDateTime(VBA.Now)
        .Range("A1:C1").Interior.Color = VBA.RGB(221, 235, 247)
        With .Range("A2")
            .Value = "file/process name"
            .Interior.Color = VBA.RGB(128, 128, 128)
            .Font.Name = "Arial"
            .Font.ThemeFont = xlThemeFontMajor
            .Font.Size = "14"
            .Font.Color = VBA.RGB(255, 242, 204)
        End With
        With .Range("B2")
            .Value = "app name"
            .Interior.Color = VBA.RGB(128, 128, 128)
            .Font.Name = "Arial"
            .Font.ThemeFont = xlThemeFontMajor
            .Font.Size = "14"
            .Font.Color = VBA.RGB(255, 242, 204)
        End With
        .Range("A3").Activate
    Else
        .Range("A" & lastrow + 2) = ComputerName
        .Range("B" & lastrow + 2) = UserName
        .Range("C" & lastrow + 2) = VBA.FormatDateTime(VBA.Now)
        .Range("A" & lastrow + 2 & ":" & "C" & lastrow + 2).Interior.Color = VBA.RGB(221, 235, 247)
        With .Range("A" & lastrow + 3)
            .Value = "file/process name"
            .Interior.Color = VBA.RGB(128, 128, 128)
            .Font.Name = "Arial"
            .Font.ThemeFont = xlThemeFontMajor
            .Font.Size = "14"
            .Font.Color = VBA.RGB(255, 242, 204)
        End With
        With .Range("B" & lastrow + 3)
            .Value = "app name"
            .Interior.Color = VBA.RGB(128, 128, 128)
            .Font.Name = "Arial"
            .Font.ThemeFont = xlThemeFontMajor
            .Font.Size = "14"
            .Font.Color = VBA.RGB(255, 242, 204)
        End With
        .Range("A" & lastrow + 4).Activate
    End If
End With

i = 0

On Error Resume Next
ReDim ArrInput(0)
On Error GoTo 0

xHandle = apiGetWindow(apiGetDesktopWindow(), mcGWCHILD)

Do While xHandle <> 0
    xStr = VBA.String$(mconMAXLEN - 1, 0)
    xStrLen = apiGetWindowText(xHandle, xStr, mconMAXLEN)
    If xStrLen > 0 Then
        xStr = VBA.Left$(xStr, xStrLen)
        xHandleStyle = apiGetWindowLong(xHandle, mcGWLSTYLE)
        If xHandleStyle And mcWSVISIBLE Then
            ArrInput(i) = xStr
            i = i + 1
            ReDim Preserve ArrInput(i)
        End If
    End If
    xHandle = apiGetWindow(xHandle, mcGWHWNDNEXT)
Loop

If i > 0 Then
    For x = LBound(ArrInput) To UBound(ArrInput)
        ArrOutput = Split((ArrInput(x)), "-")
        On Error Resume Next
        ActiveCell.Value = ArrOutput(0)
        ActiveCell.Offset(0, 1) = VBA.Right(ArrInput(x), VBA.Len(ArrInput(x)) - getLastOcurrence(ArrInput(x), "-") + 1)
        On Error GoTo 0
        ActiveCell.Offset(1, 0).Activate
    Next x
End If

With ActiveSheet
    .Columns.AutoFit
    .Rows.WrapText = False
    .Visible = xlSheetVeryHidden
    .Protect UnlockSheet
End With

Application.ThisWorkbook.Worksheets("Folha1").Activate ' changez le nom de la feuille, pour le nom que vous voulez toujours avoir comme visible
Application.ScreenUpdating = True

End Sub

Function getLastOcurrence(xStr As String, xChar As String)

Dim xLen As Integer, i As Long
xLen = VBA.Len(xStr)

For i = xLen To 1 Step -1
    If VBA.Mid(xStr, i - 1, 1) = xChar Then
        getLastOcurrence = i
        Exit Function
    End If
Next i

End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

On Error Resume Next
WorksheetExists = (ThisWorkbook.Sheets(WorksheetName).Name <> "")
On Error GoTo 0

End Function

Public Function GetPassword(XPassword As String)

GetPassword = "1234" 'changez le mot de passe ici

End Function
 

Rhysand

XLDnaute Junior
Bonsoir à tous

par exemple

dans un module standard, copiez et collez le code suivant
Je mets un délai de 5 secondes au cas où la feuille de calcul Excel perdrait le focus, pour démarrer les procédures


VB:
Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long

Public Sub checkFocus()
    If GetActiveWindow <> 0 Then
        ' Excel application; Thisworkbook; ActiveSheet with focus
        'Application.ThisWorkbook.Worksheets("Feuille2").Range("A1").Value = "Excel IS active - " & VBA.FormatDateTime(VBA.Now)
    Else
        ' Excel application; Thisworkbook; ActiveSheet without focus
'        Application.ThisWorkbook.Worksheets("Feuille2").Range("B1").Value = "Excel NOT active - " & VBA.FormatDateTime(VBA.Now)
        Call getAppList
    End If
End Sub

Public Sub RunTimerCheck()
    Application.OnTime Procedure:="checkFocus", EarliestTime:=Now + TimeValue("00:00:05")
End Sub


dans le module de feuille Excel (Feuille qui devrait toujours être active), copiez et collez le code suivant


VB:
Private Sub Worksheet_Deactivate()

Call RunTimerCheck

End Sub
 

Discussions similaires

Haut Bas