某 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

书单

《银河系漫游指南》

《宇宙尽头的餐馆》

《生命,宇宙及一切》

《再见,多谢你们的鱼》

《基本上无害》

《银河帝国:基地》

《银河帝国2:基地与帝国》

《银河帝国3:第二基地》

《银河帝国8:我,机器人》

《银河帝国14:机器人与帝国》

《阿西莫夫机器人短篇合集》

《沙丘》

《哈利·波特与魔法石》

《哈利·波特与密室》

《哈利·波特与阿兹卡班囚徒》

《哈利·波特与火焰杯》

《哈利·波特与凤凰社》

《哈利·波特与“混血王子”》

《哈利·波特与死亡圣器》

《三体》

《三体2:黑暗森林》

《三体3:死神永生》

《2018》

《时间移民》

《球状闪电》

《乡村教师》

《飘》

《岛》

《线》

《回归》

《无人生还》

《东方快车谋杀案》

《尼罗河上的惨案》

《阳光下的罪恶》

《不能承受的生命之轻》

《简·爱》

《偷书贼》

《汤姆叔叔的小屋》

《芒果街上的小屋》

《苏菲的世界》

《灿烂千阳》

《追风筝的人》

《群山回唱》

《教父》

《永远的教父》

《西西里人》

《三杯茶》

《偷影子的人》

《日出酒店》

《悲惨世界》

《海边的卡夫卡》

《基督山伯爵》

《傲慢与偏见》

《格兰特船长的儿女》

《海底两万里》

《神秘岛》

《金银岛》

《幸福了吗》

《看见》

《寻路中国》

《目送》

《野火集》

《红尘菩提》

《文化苦旅》

《双城记》

《乔布斯传——神一样的传奇》

《史蒂夫·乔布斯传》

《20个月赚130亿:YouTube创始人陈士骏自传》

《悖论》

《雪国》

《且听风吟》

《白夜行》

《放学后》

《悬疑人X的献身》

《月亮和六便士》

《伟大的盖茨比》

《霍乱时期的爱情》

《我所理解的生活》

《百万英镑》

《乖,摸摸头》

《他们最幸福》

《明朝那些事儿》

《送你一颗子弹》

《一桩事先张扬的凶杀案》

《小王子》

《欧·亨利短篇小说选》

《围城》

《活着》

《野火集》

《四世同堂》

《呼兰河传》

《撒哈拉的故事》

《星际迷航:红杉》

《文学回忆录》

《色彩设计的原理》

《民主的细节》

《古文观止》

《国富论》

《世界是平的》

《牛奶可乐经济学》

《经济学原理》微观分册

《时间简史》

《果壳中的宇宙》

《大设计》

《上帝掷骰子吗?量子物理史话》

《法律简史》

Best Of Quora

《台北人》

《纽约客》

《浮生六记》

《动物农场》

《1984》

《达芬奇密码》

《生活在别处》

《人类群星闪耀时》

《在路上》

《摆渡人》

安卓Swap教程

概述:以/cache/swap.img为例,大小为128M>【1】

要求:Android Debug Bridge工具包、驱动(device)、ROOT、/cache分区中至少有128M剩余空间>【1】

步骤:

  1. 开启USB调试,手机连电脑
  2. 输入adb shell
  3. su
  4. mount -o remount,rw /cache()
  5. swapoff /dev/block/loop7
  6. dd if=/dev/zero of=/cache/swap.img bs=1024 count=131072  ——输入这一行以后,等一下,因为它要创建一个swap文件,等它出了两行英文再继续往下输 【1】
  7. losetup /dev/block/loop7 /cache/swap.img
  8. mkswap /dev/block/loop7
  9. swapon /dev/block/loop7
  10. free  ——swap行不为0则OK
  11. 手机打开system/bin/sysinit
  12. 在最后加上『mount -o remount,rw /cache;

    losetup /dev/block/loop7 /cache/swap.img;

    mkswap /dev/block/loop7;

    swapon /dev/block/loop7;

    sysctl -w vm.swappiness=10;  ——设置swap分区的优先级为10(默认为60)>【2】

注释:

【0】:需要内核支持

【1】:若在其他地方开启swap需将所有”cache“改为”X“(e.g. system),步骤6中”count=“后面的数字为swap大小(kb),需保证改分区剩余空间大于swap的大小

【2】:优先级与数字正相关