Dim strSrcFolder, strTgtFolder, varDays, olkApp, olkSes, olkSrc, olkTgt, olkLst, olkItm, intCnt
If WScript.Arguments.Count < 3 Then
WScript.Echo "You must pass three arguments to the script."
Else
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
strSrcFolder = WScript.Arguments.Item(0)
strTgtFolder = WScript.Arguments.Item(1)
varDays = WScript.Arguments.Item(2)
If OutlookFolderExists(strSrcFolder) Then
If OutlookFolderExists(strTgtFolder) Then
If IsNumeric(varDays) Then
Set olkSrc = OpenOutlookFolder(strSrcFolder)
Set olkTgt = OpenOutlookFolder(strTgtFolder)
Set olkLst = olkSrc.items.restrict("[ReceivedTime] <= '" & OutlookSearchDateFormat(DateAdd("d", varDays * -1, Now)) & "'")
For intCnt = olkLst.Count To 1 Step -1
Set olkItm = olkLst.item(intCnt)
olkItm.Move olkTgt
Next
Else
MsgBox "The number of days you sepcified is not a number.",vbCritical+vbOKOnly,"Script Processing Terminated"
End If
Else
MsgBox "The target folder you specified does not exists.",vbCritical+vbOKOnly,"Script Processing Terminated"
End If
Else
MsgBox "The source folder you specified does not exists.",vbCritical+vbOKOnly,"Script Processing Terminated"
End If
End If
Set olkItm = Nothing
Set olkLst = Nothing
Set olkTgt = Nothing
Set olkSrc = Nothing
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
WScript.Quit
Function OutlookSearchDateFormat(varDate)
OutlookSearchDateFormat = FormatDateTime(varDate, vbShortDate) & " " & Hour(vardate) & ":" & Minute(vardate) & " " & AMPM(varDate)
End Function
Function AMPM(varDate)
If Hour(varDate) >= 12 Then
AMPM = "PM"
Else
AMPM = "AM"
End If
End Function
Function OutlookFolderExists(strFolderPath)
' Purpose: Tests to see if an Outlook folder exists based on a path string.'
' Written: 4/24/2009'
' Author: BlueDevilFan'
' Outlook: All versions'
OutlookFolderExists = (TypeName(OpenOutlookFolder(strFolderPath)) <> "Nothing")
End Function
Function OpenOutlookFolder(strFolderPath)
' Purpose: Opens an Outlook folder from a folder path.'
' Written: 4/24/2009'
' Author: BlueDevilFan'
' Outlook: All versions'
Dim arrFolders, varFolder, bolBeyondRoot
On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = olkSes.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function
|