'activer l'[accès approuvé au modele d'object du projet vba] par VBA
'patricktoulon
'ici l'exemple est simple
'nous allons lancer en différer une procedure qui va se chager de taper les touche en addressOf avec l'api settimer
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
Dim TimerID As LongPtr
#Else
Private Declare Function SetTimer Lib "user32" ( _
ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" ( _
ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Dim TimerID As Long
#End If
' Cette procédure va être appelée automatiquement par le timer
Public Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal idEvent As LongPtr, ByVal dwTime As Long)
Dim Touchest As Byte, i As Byte
KillTimer 0, TimerID
touches = Array(&H9, &H9, &H20, &HD)
For i = 0 To UBound(touches)
keybd_event touches(i), 0, 0, 0 'apuie
keybd_event touches(i), 0, &H2, 0 'relache
Next
'ne pas tester le resultat ici ça declenche l'erreur out of memory bien connue du settimer
End Sub
Sub AccesVBOM_Timer()
Dim Test_AccesVBOM, delayx As Long, essais As Long, dem As VbMsgBoxResult
delayx = 1000
re:
On Error Resume Next
Test_AccesVBOM = ThisWorkbook.VBProject.VBComponents(1).Name 'on test l'accès
' si erreur on lance la procedure d'activation avec le cochage différé
If Err Then
Err.Clear
' Lancer le timer (retard de 300ms ici)
TimerID = SetTimer(0, 0, delayx, AddressOf TimerProc)
' Ouvrir la boîte sécurité
Application.CommandBars.ExecuteMso "MacroSecurity"
Else
MsgBox " ""L'accès approuvé a l'object du modèle de projet vba"" est dèjà activé!!": Exit Sub
End If
'créer un test ici en ajoutant un delay non bloquant
Application.Wait Now + 0.00001 'on peut faire un wait bloquant ici on s'en fou puisque de toute facon on a 1 seconde d'attente avant que la proc active l'accès approuvé
Test_AccesVBOM = ThisWorkbook.VBProject.VBComponents(1).Name 'on test l'accès
'si err alors
If Err Then
' si essais =0 on peut relancer une fois sur demande
If essais = 0 Then
dem = MsgBox("Vba n'a pas pu activé l'accès approuvé a l'object du modèle de projet vba" & vbCrLf & _
"Voulez vous faire une autre tentative avec un delay d'une seconde et demiet?", vbYesNo)
If dem = vbYes Then
delayx = delayx + 500
essais = 1
GoTo re
End If
Else
MsgBox "c'est peine perdue"
End If
End If
On Error GoTo 0
End Sub
