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