Browse Category

VBS

某 Copy PPT 的小程序

本程序将所有打开过的 PowerPoint 文件依日期归类至本地及网盘存档,同时发送至指定邮箱,并支持添加自定义扩展。


On Error Resume Next
Dim fso,WS
Dim BaseFolderList
Public Const vbQuote = """"
Set fso = CreateObject("Scripting.FileSystemObject")
Set WS = CreateObject("WScript.Shell")
StartLog = WriteMainLog("#OK_ScriptStart#")
BaseFolderList = "F:\ppt\,E:\WindowsBackup\SkyDrive\autosaved\"
PPTPath = ModArgs
'msgbox(PPTPath)
SafePath = FirstCopy(PPTPath)
StartAPPErr = WriteMainLog(StartAPP(PPTPath))
'WScript.Sleep 2000
WScript.Sleep 20000
If ExcludeBackupFolder(PPTPath) > 0 Then
WhyNotCopy = WriteMainLog("#OK_SkipCopy#" & vbTab & PPTPath)
WScript.Quit
Else
If AllCopy(SafePath) > 0 Then MailErr = WriteMainLog(SendMailWithZip(SafePath))
End If
If fso.FileExists("F:\software\shell\pptshell.vbs") Then
RunZero = WS.Run "F:\software\shell\pptshell.vbs",0
RunShellLog = WriteMainLog("#OK_RunShell#" vbTab & RunZero)
End If
Set fso = Nothing
Set WS = Nothing

Function ModArgs
Dim Args
Set Args = WScript.Arguments
ArgNum = 0
Do While ArgNum < Args.Count
AllArgs = AllArgs & "" & Args(ArgNum)
ArgNum = ArgNum + 1
Loop
ModArgs = AllArgs
Set Args = Nothing
End Function 

Function StartAPP(FileToBeOpened)
'On Error Resume Next
Err.Clear
FileType = fso.GetExtensionName(FileToBeOpened)
If left(FileType,1) = "p" Then
WS.Run """C:\Program Files (x86)\Microsoft Office\Office15\POWERPNT.EXE""" & " " & chr(34) & FileToBeOpened & chr(34),,False
Else
WS.Run """C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE""" & " " & chr(34) & FileToBeOpened & chr(34),,False
End If
If Err.Number <> 0 Then
StartAPP = "#Error_StartAPP#" & vbTab & FileToBeOpened & vbTab & Err.Number & vbTab & Err.Source & vbTab & Err.Description
Else
StartAPP = "#OK_StartAPP#" & vbTab & FileToBeOpened
End If
End Function

Function FirstCopy(OriginalPath)
Err.Clear
CopyTempFolder = fso.GetParentFolderName(WScript.ScriptFullName) & "\FirstCopied"
If Not fso.FolderExists(CopyTempFolder) Then SCreatFolder CopyTempFolder
fso.CopyFile OriginalPath,CopyTempFolder & "\",True
FirstCopy = CopyTempFolder & "\" & fso.GetFileName(OriginalPath)
If Err.Number <> 0 Then
	FirstCopyErr = WriteMainLog("#Error_FirstCopy#" & vbTab & OriginalPath & vbTab & Err.Number & vbTab & Err.Source & vbTab & Err.Description)
	Else
	FirstCopyErr = WriteMainLog("#OK_FirstCopy#" & vbTab & OriginalPath)
End If
End Function

Function WriteMainLog(LogDetails)
'On Error Resume Next
Err.Clear
If Not fso.FolderExists("F:\Software\Shell") Then SCreatFolder "F:\Software\Shell"
Set MainLogFile = fso.OpenTextFile("F:\Software\Shell\PPTLog.txt",8,True)
MainLogFile.WriteLine (Now & vbTab & LogDetails)
MainLogFile.Close
Set MainLogFile = Nothing
'Call NowSync
WriteMainLog = Err.Number
End Function

Function ExcludeBackupFolder(TestPath)
'On Error Resume Next
BaseFolders = Split(BaseFolderList,",")
ExcludeBackupFolder = 0
For Each BaseFolder In BaseFolders
If BaseFolder = fso.GetParentFolderName(fso.GetParentFolderName(TestPath)) Then ExcludeBackupFolder = ExcludeBackupFolder + 1
Next
End Function

Function AllCopy(SourcePPT) 'No Quote
	'On Error Resume Next
	Err.Clear
	BaseFolders = Split(BaseFolderList,",")
	AllCopy = 0
	For Each BaseFolder In BaseFolders
		TodayFolder = BaseFolder & GetCurrentDate
		TodayPPT = TodayFolder & "\" & fso.GetFileName(SourcePPT)
		'msgbox TodayFolder & "," & GetCurrentDate
		If Not fso.FolderExists(TodayFolder) Then
		WriteMainLog(SCreatFolder(TodayFolder))
		End If
		If Not fso.FileExists(TodayPPT) Then
		AllCopy = AllCopy + 1
		'Else
		'SourceFileSize = fso.GetFile(SourcePPT).Size
		'TargetFileSize = fso.GetFile(TodayPPT).Size
		'If TargetFileSize <> SourceFileSize Then AllCopy = AllCopy + 1
		End If
		fso.CopyFile SourcePPT,TodayFolder & "\",True
		Set LogFile = fso.OpenTextFile(TodayFolder & "\Log.txt",8,True)
		LogFile.WriteLine(Now & vbTab & SourcePPT)
		LogFile.Close
		Set LogFile = Nothing
	Next
	If Err.Number <> 0 Then
	CopyErr = WriteMainLog("#Error_Copy#" & vbTab & Err.Number & vbTab & Err.Source & vbTab & Err.Description)
	Else
	 CopyErr = WriteMainLog("#OK_Copy#" & vbTab & SourcePPT)
	End If
End Function

Function GetCurrentDate
	If Month(now) <= 9 Then DMo = "0" & Month(now) ELse DMo = Month(now)
	If Day(now) <= 9 Then DD = "0" & Day(now) Else DD = Day(now)
	GetCurrentDate = Year(now) & DMo & DD
End Function

Function SCreatFolder(TheCreatingFolder) 'No Back-Slant
	'On Error Resume Next
	Err.Clear
	Dim PFolderPath
	PFolderPath = fso.GetParentFolderName(TheCreatingFolder) 'Except For Root Directory, No Back-Slant
	If Not fso.FolderExists(PFolderPath) Then
	TryCreatSubSFolder = SCreatFolder(PFolderPath)
	End If
	fso.CreateFolder TheCreatingFolder
	If Err.Number <> 0 Then
	SCreatFolder = "#Error_SCreatFolder#" & vbTab & Err.Number & vbTab & Err.Source & vbTab & Err.Description
	Else
	SCreatFolder = "#OK_SCreatFolder#" & vbTab & TheCreatingFolder
	End If
End Function

Function SendMailWithZip(ByVal ZPath)
 'On Error Resume Next
 Err.Clear
 SFileName = fso.GetFileName(ZPath)
	Set Email = CreateObject("CDO.Message")
	NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
	Email.From = "username@163.com"
	Email.To = "username@163.com"
	Email.Subject = SFileName & " #PPTAuto#"
	If ZPath <> "" Then Email.AddAttachment ZPath
	 Email.Textbody = ZPath
	With Email.Configuration.Fields
		.Item(NameSpace & "sendusing") = 2
		.Item(NameSpace & "smtpserver") = "smtp.163.com"
		.Item(NameSpace & "smtpserverport") = 465
		.Item(NameSpace & "smtpauthenticate") = 1
		.Item(NameSpace & "smtpusessl") = True
		.Item(NameSpace & "sendusername") = "username@163.com"
		.Item(NameSpace & "sendpassword") = "password"
		.Update
	End With
	Err.Clear
	Email.Send
	If Err.Number <> 0 Then
SendMailWithZip = "#Error_SendMail#" & vbTab & ZPath & vbTab & Err.Number & vbTab & Err.Source & vbTab & Err.Description
	Else
	SendMailWithZip = "#OK_SendMail#" & vbTab & ZPath
	Set Email = Nothing
	End If
End Function

Function KillProcess(ProcessName)
'On Error Resume Next
Err.Clear
Set WMIService = GetObject("winmgmts:\\.\root\cimv2")
Set ProcessList = WMIService.execquery(" Select * From win32_process where name ='" & ProcessName & "' ")
For Each Process in ProcessList
IntReturn = 1 'Process.terminate
If intReturn <> 0 Then WshShell.Run "CMD /c ntsd -c q -p " & Process.Handle, vbHide, False
Next
If Err.Number <> 0 Then
KillProcess = "#Error_KillProcess#" & vbTab & ProcessName & vbTab & Err.Number & vbTab & Err.Source & vbTab & Err.Description
Else
KillProcess = "#OK_KillProcess#" & vbTab & ProcessName
End If
Set WMIService = Nothing
Set ProcessList = Nothing
End Function

Function NowSync
 Err.Clear
 NowSync = WriteMainLog(KillProcess("OneDrive.exe"))
 WS.Run "C:\Users\1306\AppData\Local\Microsoft\OneDrive\OneDrive.exe",vbHide,False
 If Err.Number <> 0 Then
	NowSync = "#Error_StartOneDriveExe#" & Err.Number & vbTab & Err.Source & vbTab & Err.Description
	Else
	NowSync = "#OK_StartOneDriveExe#"
	End If
End Function