Bonjour,
J'avais une programmation VBA qui fonctionnait bien il y a quelques années, mais maintenant, ça me dit qu'il y a des erreurs de compilation et erreur avec le 64 bits..... Pourriez-vous mettre à jour mon VBA pour que ça fonctionne comme avant? Voici mon code VBA à mettre à jour :
J'avais une programmation VBA qui fonctionnait bien il y a quelques années, mais maintenant, ça me dit qu'il y a des erreurs de compilation et erreur avec le 64 bits..... Pourriez-vous mettre à jour mon VBA pour que ça fonctionne comme avant? Voici mon code VBA à mettre à jour :
VB:
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function apiGetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As LongPtr, ByVal lpClassname As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As LongPtr
Private Declare PtrSafe Function apiGetWindow Lib "user32" Alias "GetWindow" (ByVal Hwnd As LongPtr, ByVal wCmd As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal Hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As LongPtr, ByVal lpString As String, ByVal aint As LongPtr) As LongPtr
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 LongPtr, xHandle As LongPtr, xHandleLen As LongPtr, xHandleStyle As LongPtr
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 = apiGetWindowLongPtr(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 LongPtr
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
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
Dernière modification par un modérateur:
