vba timer outlook

[kriszty]

the code runs one time, it checks all active mailboxes in the junk folder and move these items to their inbox. problem is i can run it only once or activate by itemadd
but only on the default inbox. script is made for multiple users with not all the same mailboxes

question: can i run it on schedule or time base ? ( sleep does not work ! )
or how program the itemadd function on multiple ( and different users ) mailboxes by array i think ?

Option Explicit

Public foldernaam As String
Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Sleep 5
ShowActiveMailboxes
Dim objApp As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim inboxFol As Object  'Outlook.Folder
Set objApp = Outlook.Application
Set objNamespace = objApp.GetNamespace("MAPI")
Set Items = objNamespace.GetDefaultFolder(olFolderJunk).Items
Dim Items2 As Outlook.Items
Dim mail As Object
Dim olNS As Outlook.NameSpace
Dim subfolder As Outlook.MAPIFolder
Dim i As Long
Dim Item3 As Object
Set olNS = Application.GetNamespace("MAPI")
Set mail = olNS.GetDefaultFolder(olFolderJunk)
Set Items2 = mail.Items
Set subfolder = olNS.GetDefaultFolder(olFolderInbox)
For i = Items2.count To 1 Step -1
    DoEvents
    'MsgBox Items2.Count
    Set Item3 = Items2(i)
    Item3.Subject = "[Possible Spam] " & Item3.Subject
    Item3.Save
    Item3.Move subfolder
Next
End Sub

Private Sub Items_ItemAdd(ByVal objItem As Object)
Sleep 4
On Error GoTo ShowError
Dim objApp As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim inboxFol As Object  'Outlook.Folder
Set objApp = Outlook.Application
Set objNamespace = objApp.GetNamespace("MAPI")
Set Items = objNamespace.GetDefaultFolder(olFolderJunk).Items
Dim Items2 As Outlook.Items
Dim mail As Object
Dim olNS As Outlook.NameSpace
Dim subfolder As Outlook.MAPIFolder
Dim i As Long
Dim Item3 As Object
Set olNS = Application.GetNamespace("MAPI")
Set mail = olNS.GetDefaultFolder(olFolderJunk)
Set Items2 = mail.Items
Set subfolder = olNS.GetDefaultFolder(olFolderInbox)
For i = Items2.count To 1 Step -1
    DoEvents
    'MsgBox Items2.Count
    Set Item3 = Items2(i)
    Item3.Subject = "[Possible Spam] " & Item3.Subject
    Item3.Save
    Item3.Move subfolder
Next
'ShowActiveMailboxes
Exit Sub
'chec shared boxes
ShowError:
MsgBox Err.Number & " - " & Err.Description
End Sub
    
Public Sub Sleep(ByVal SleepSeconds As Single)
Dim Tmr As Single
Tmr = Timer
Do While Tmr + SleepSeconds > Timer
    DoEvents
Loop
End Sub

Public Sub ShowActiveMailboxes()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Dim ns As Outlook.NameSpace
Set ns = olApp.GetNamespace("MAPI")
Dim fldr As Outlook.MAPIFolder
For Each fldr In ns.Folders
   If fldr.DefaultItemType = olMailItem Then
      'MsgBox (fldr.Name)
      foldernaam = fldr
          If foldernaam Like "*Archi*" Then
              'sla mailbox over
              ElseIf foldernaam = "No Reply" Then
              'sla over
              ElseIf foldernaam Like "*IT Supp*" Then
              'sla over
             Else
             'MsgBox (foldernaam)
            Call extra
         End If
    End If
Next
'Sleep 120
'Call Application_Startup
End Sub

Public Sub extra()
'MsgBox ("check unread mail in ") & foldernaam
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.Folder
Dim subfolder As Outlook.Folder
Dim objMailbox As Outlook.Recipient
'Dim lngUnread As Long
Dim Items2 As Outlook.Items
Dim mail As Object
Dim x As Long
Dim Item3 As Object
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objMailbox = objNamespace.CreateRecipient(foldernaam)
Set objFolder = objNamespace.GetSharedDefaultFolder(objMailbox, olFolderJunk)
Set subfolder = objNamespace.GetSharedDefaultFolder(objMailbox, olFolderInbox)
Set mail = objFolder
Set Items2 = mail.Items
'lngUnread = objFolder.UnReadItemCount
'MsgBox "There are " & lngUnread & " unread emails in the Shared Mailbox.", vbInformation
'MsgBox "aantal mails check !!!!!!! " & foldernaam & " " & (Items2.count)
For x = Items2.count To 1 Step -1
     DoEvents
     'MsgBox Items2.Count
      Set Item3 = Items2(x)
      Item3.Subject = "[Possible Spam] " & Item3.Subject
      Item3.Save
      Item3.Move subfolder
Next
End Sub

[kriszty]

just rewrote everything, now it,s checking every 5 minutes with the new code on all active mailboxes ( except for the if )

code in Module:

Public foldernaam As Variant  'use as shared folder variable name
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongLong, ByVal nIDEvent As LongLong, _
 ByVal uElapse As LongLong, ByVal lpTimerfunc As LongLong) As LongLong
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongLong, ByVal nIDEvent As LongLong) As LongLong
Public TimerID As LongLong 'Need a timer ID to eventually turn off the timer. If the timer ID <> 0 then the timer is running

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
'MsgBox "The TriggerTimer function has been automatically called!"
ShowActiveMailboxes
End Sub

Public Sub DeactivateTimer()
Dim lSuccess As LongLong
lSuccess = KillTimer(0, TimerID)
If lSuccess = 0 Then
   MsgBox "The timer failed to deactivate."
   Else
   TimerID = 0
End If
End Sub

Public Sub ActivateTimer(ByVal nMinutes As Long)
nMinutes = nMinutes * 1000 * 60 'The SetTimer call accepts milliseconds, so convert to minutes
If TimerID <> 0 Then Call DeactivateTimer 'Check to see if timer is running before call to SetTimer
  TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)
     If TimerID = 0 Then
       MsgBox "The timer failed to activate."
       MsgBox (myVariable)
    End If
End Sub

Public Sub ShowActiveMailboxes()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Dim ns As Outlook.NameSpace
Set ns = olApp.GetNamespace("MAPI")
Dim fldr As Outlook.MAPIFolder
For Each fldr In ns.Folders
   If fldr.DefaultItemType = olMailItem Then
      foldernaam = fldr
          If foldernaam Like "*Archi*" Then
             'do nothing
             ElseIf foldernaam = "No Reply" Then
             'do nothing
             ElseIf foldernaam Like "*IT Supp*" Then
             'sla over
             Else
             'MsgBox (foldernaam)
            Call extra
        End If
   End If
Next
End Sub

Public Sub extra()
'MsgBox ("check unread mail in all active mailboxes ") & foldernaam
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.Folder
Dim subfolder As Outlook.Folder
Dim objMailbox As Outlook.Recipient
Dim Items2 As Outlook.Items
Dim mail As Object
Dim x As Long
Dim Item3 As Object
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objMailbox = objNamespace.CreateRecipient(foldernaam)
Set objFolder = objNamespace.GetSharedDefaultFolder(objMailbox, olFolderJunk)
Set subfolder = objNamespace.GetSharedDefaultFolder(objMailbox, olFolderInbox)
Set mail = objFolder
Set Items2 = mail.Items
For x = Items2.Count To 1 Step -1
    DoEvents
    'MsgBox check for all items junkbox
    Set Item3 = Items2(x)
    Item3.Subject = "[Possible Spam] " & Item3.Subject
    Item3.Save
    Item3.Move subfolder
Next
End Sub

Code in Thisoutlook session ( it only activates the timer

Private Sub Application_Quit()
If TimerID <> 0 Then Call DeactivateTimer 'Turn off timer upon quitting **VERY IMPORTANT**
End Sub

Private Sub Application_Startup()
Call ActivateTimer(5) 'Set timer to go off every 5 minute
End Sub