Otomatik Makro Çalıştırma

[baysevimli]

Arkadaşlar Merhaba,

Aşağıdaki makromun her 10 dakika da bir otomatik çalışmasını istiyorum. Kod üzerinde güncelleme yapıp paylaşabilir misiniz lütfen ?





Option Explicit

Private lRow As Long, x As Date, oWS As Worksheet

Sub GetFromInbox()
Const olFolderInbox = 6
Dim olApp As Object, olNs As Object
Dim oRootFldr As Object ' Root folder to start
Dim lCalcMode As Long

Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set oRootFldr = olNs.GetDefaultFolder(olFolderInbox)
Set oWS = ActiveSheet

x = Date
lRow = 1
lCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
GetFromFolder oRootFldr
Application.ScreenUpdating = True
Application.Calculation = lCalcMode

Set oWS = Nothing
Set oRootFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object)
Dim oItem As Object, oSubFldr As Object

' Process all mail items in this folder
For Each oItem In oFldr.Items
If TypeName(oItem) = "MailItem" Then
With oItem
If .Subject = "Is Goremezlik Raporu" Then
oWS.Cells(lRow, 1).Value = .Subject
oWS.Cells(lRow, 2).Value = .ReceivedTime
oWS.Cells(lRow, 3).Value = .SenderName
oWS.Cells(lRow, 4).Value = .body

lRow = lRow + 1
End If
End With
End If
Next

' Recurse all Subfolders
For Each oSubFldr In oFldr.Folders
GetFromFolder oSubFldr
Next
End Sub