Hi,
I use this script in VBS:
ReDim pst(1)
pst(0) = "C:\Outlook\name 1 file.pst"
pst(1) = "C:\Outlook\name 2 file.pst"
Const DeleteReadOnly = True
BackupPath = "c:\BackupPSTTemp\"
KeepHistory = FALSE
delay = 30000
start = TRUE
move = TRUE
DeleteTemp = TRUE
Call CloseOutlook(delay)
Call BackupPST(pst, BackupPath, KeepHistory)
If start = TRUE Then
Call OpenOutlook()
End If
If move = TRUE Then
Call CopyAllToServer()
End If
If DeleteTemp = TRUE Then
Call EraseTemp()
End IF
Call NotifyWhenDone()
Sub CloseOutlook(delay)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
For Each Process in objWMIService.InstancesOf("Win32_Process")
If StrComp(Process.Name,"OUTLOOK.EXE",vbTextCompare) = 0 Then
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
WScript.Sleep delay
Exit For
End If
Next
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'Outlook.exe'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Set objWMIService = Nothing
Set ObjOutlook = Nothing
Set colProcessList = Nothing
End Sub
Sub BackupPST(pst, BackupPath, KeepHistory)
Set fso = CreateObject("Scripting.FileSystemObject")
If KeepHistory = True Then
ArchiveFolder = Year(Now) & "-" & Month(Now) & "-" & Day(Now)
BackupPath = BackupPath & ArchiveFolder & "\"
End If
If fso.FolderExists(BackupPath) = False Then
fso.CreateFolder BackupPath
End If
For Each pstPath in pst
If fso.FileExists(pstPath) Then
fso.CopyFile pstPath, BackupPath, TRUE
End If
Next
Set fso = Nothing
End Sub
Sub OpenOutlook()
Set objShell = CreateObject("WScript.Shell")
objShell.Run "Outlook.exe"
End Sub
Sub CopyAllToServer()
With CreateObject("Scripting.FileSystemObject")
.CopyFile "c:\BackupPSTTemp\*.*", "l:\serverpath", True
End with
End Sub
Sub NotifyWhenDone()
WScript.echo "PST-Files moved to launchpad and then copied to server."
End Sub
Sub EraseTemp()
Set objFSO = CreateObject ("Scripting.FileSystemObject")
objFSO.DeleteFile("c:\BackupPSTTemp\*"),DeleteReadOnly
End Sub
Works fine untill I try running it with Scheduler.
Then I get error "ActiveX component can't create object: 'Outlook.Appplication' Code: 800A01AD for line 46
Line 46 being: Set objOutlook = CreateObject("Outlook.Application")
Any help would be greatly appreciated.
I run this one on Win 10 with Office 2013 installed.
Kind Regards,
Kris
