VBS编写的一个小程序

REM Author : Laycher
REM DATE：2015-11-23
DIM target_dir,hybh,shpbu,today,tomorrow,content,srcFile,srcPath,rarPath
DIM zyhgName,zyhgTxtFullName,zyhgFlgFullName,zxbsName,zxbsRarFullName,zxbsFlgFullName
DIM fileName,fileDate,fileTime,fileSize,fileRows,fileMD5,fileCount
DIM x,s
 
REM ?????对应的值
hybh="00102"
REM XXXXX对应的值
shpbu="20801"
REM rar的具体路径
rarPath="D:\Program Files\TotalCMD64\Plugins\wcx\Rar\Rar.exe"
 
 
REM -------------------------------------------------------------以下是程序代码，不需要修改----------------------------------------------------
MsgBox "作者：Laycher"&VbCrlf&VbCrlf&"提示：点击确定后请在后面的文件选择框中选择恒生导出来的txt文件，此程序会删除文件中的前两行，无需手工删除。另外选择的文件目录请不要包含zyhg开头的多余文件。"&VbCrlf&"Tips：脚本执行稍微有点慢，大概15秒左右处理完成",vbInformation,"相关提示"
today=year(Now)&Month(Now)&day(Now)
tomorrow=DateAdd("d", 1, date)
REM 只存在明天是周六的情况
if DatePart("w", tomorrow,"2") ="6" then
	tomorrow=DateAdd("d", 2, tomorrow)
end if
 
tomorrow=DatePart("yyyy",tomorrow) & Right("0" & DatePart("m",tomorrow), 2)  & Right("0" & DatePart("d",tomorrow),2)
 
REM 选择要处理的源文件
srcFile=BrowseForFile()
If srcFile ="" Then 
	REM 未选择则直接退出
	Wscript.Quit 
End IF
REM 获取源文件路径
target_dir=getFilePath(srcFile)
REM 
 
x=msgbox("文件所在目录为："&target_dir&VbCrlf&"当日日期是："&today&VbCrlf&"下一交易日："&tomorrow&VbCrlf&"rar.exe的路径："&rarPath&VbCrlf&"?????的值："&hybh&VbCrlf&"XXXXX的值："&shpbu&VbCrlf&VbCrlf&"是否正确？"&VbCrlf&"如果不正确请修改脚本中的内容。",4097,"请确认")
'CreateObject("wscript.shell").sendkeys "{enter}"
 
if x=Vbcancel then
	Wscript.Quit
elseif x=VbOk Then
	REM  先拷贝成要求的txt文件
	Set FSO=CreateObject("Scripting.FileSystemObject")
	REM Set f1=fso.GetFile(target_dir&"\test.txt")
	zyhgName="zyhg"&hybh&"001"&today
	zyhgTxtFullName=target_dir&"\"&zyhgName&".txt"
	zyhgFlgFullName=target_dir&"\"&zyhgName&".flg"
	zxbsName="zxbs"&shpbu&tomorrow&"001"
	zxbsRarFullName=target_dir&"\"&zxbsName&".rar"
	zxbsFlgFullName=target_dir&"\"&zxbsName&".flg"
 
	REM 先删除原先的文件
	deleteFile(zyhgTxtFullName)
	deleteFile(zyhgFlgFullName)
	deleteFile(zxbsRarFullName)
	deleteFile(zxbsFlgFullName)
 
	REM 把源文件拷贝成目标文件
	fso.CopyFile srcFile,zyhgTxtFullName,False
 
	REM 删除多余的前两行
	DeleteLine zyhgTxtFullName,"",1,0
	DeleteLine zyhgTxtFullName,"",1,0
 
	REM 拼凑flg文件中的内容
	fileSize=getFileSize(zyhgTxtFullName)
	fileDate=getFileCreateDate(zyhgTxtFullName)
	fileTime=getFileCreateTime(zyhgTxtFullName)
	fileRows=getFileRows(zyhgTxtFullName)
	fileMD5=getFileMD5(zyhgTxtFullName)
 
	content=zyhgName&".txt"&space(60-len(zyhgName&".txt"))&"¦"&fileSize&space(16-len(fileSize))&"¦"&fileDate&"¦"&fileTime&"¦"&fileRows&space(12-len(fileRows))&"¦"&fileMD5&space(64-len(fileMD5))&"¦"&Space(64)
 
	REM 生成对应的flg文件
	createFile zyhgFlgFullName,content
 
	REM 创建RAR文件
	rarFiles rarPath,zxbsRarFullName,target_dir,"zyhg*"
	REM 必须要等一下，否则后面执行太快，找不到文件的
	WScript.Sleep 1000 '1000毫秒 
	'MsgBox "压缩完成"&zxbsRarFullName
	REM 拼凑flg文件中的内容
	fileSize=getFileSize(zxbsRarFullName)
	fileDate=getFileCreateDate(zxbsRarFullName)
	fileTime=getFileCreateTime(zxbsRarFullName)
	fileCount=getFileCount(target_dir,"zyhg")
	fileMD5=getFileMD5(zxbsRarFullName)
 
	content=zxbsName&".rar"&space(60-len(zxbsName&".rar"))&"¦"&fileSize&space(16-len(fileSize))&"¦"&fileDate&"¦"&fileTime&"¦"&fileCount&space(12-len(fileCount))&"¦"&fileMD5&space(64-len(fileMD5))&"¦"&Space(64)
 
	REM 生成对应的flg文件
	createFile zxbsFlgFullName,content
 
	MsgBox "文件生成完成，请上传!"&vbCrLf&"路径："&target_dir,vbInformation,"完成"
Else 
	Wscript.Quit
end if
REM 退出
Wscript.Quit
 
REM --------------------------------------------------------以下是调用的函数------------------------------------------------------------
'获取文件大小
'fileName	文件路径和文件名组成
'Return		文件大小，单位为字节
function getFileSize(fileName) 
	Dim fso, f, s   
	Set fso = CreateObject("Scripting.FileSystemObject")   
	REM Set f = fso.GetFolder(filespec)
	If fso.FileExists(fileName) Then
		Set f = fso.GetFile(fileName)
		getFileSize=f.size
	Else
		MsgBox fileName&"不存在，请检查脚本",48,"错误提示"
	End If
	REM s = UCase(f.Name) & " 大小为 " & f.size & " 字节。"
end function 
 
'获取文件创建日期
'fileName	文件路径和文件名组成
'Return		文件的创建日期，YYYYMMDD格式
function getFileCreateDate(fileName) 
	set fso=createobject("Scripting.FileSystemObject")
	set fn=fso.GetFile(fileName)
	getFileCreateDate=Replace(Left(fn.DateCreated,Instr(fn.DateCreated," ")-1),"/","")
end function 
 
'获取文件创建时间
'fileName	文件路径和文件名组成
'Return		文件的创建时间，HHMMSS格式
function getFileCreateTime(fileName) 
	set fso=createobject("Scripting.FileSystemObject")
	set fn=fso.GetFile(fileName)
	getFileCreateTime=Replace(Mid(fn.DateCreated,InstrRev(fn.DateCreated," ")+1),":","")
end function 
 
'Function ReadAllTextFile 
''vbCr Chr(13) 回车符。 
''vbCrLf 搜索Chr(13) & Chr(10) 回车符与换行符。  
''vbLf Chr(10) 换行符。
' Const ForReading = 1, ForWriting = 2  
' Dim fso, f  
' Set fso = CreateObject("Scripting.FileSystemObject")  
' Set f = fso.OpenTextFile("c:testfile.txt", ForWriting, True)  
' f.Write "世界你好!"  
' Set f = fso.OpenTextFile("c:testfile.txt", ForReading)  
'ReadAllTextFile =  f.ReadAll
' End Function
 
'获取文件行数
'fileName	文件路径和文件名组成
'Return		文件的行数，根据回车符来计算的
function getFileRows(fileName)
	set fso=createobject("Scripting.FileSystemObject")
	set fn=fso.opentextfile(fileName,1)
	'msgbox(fn.readall)
	getFileRows=ubound(split(fn.readall,vbCrLf))
	fn.close
end Function
 
'获取文件行数
'filePath  	文件路径和文件名组成
'strKey  	左起的关键字
'Return		文件的行数，根据回车符来计算的
function getFileCount(filePath,strKey)
	set fso=CreateObject("Scripting.FileSystemObject")
	for each f in fso.getfolder(filePath).files
		'if fso.getextensionname(f.path)="wma" then k=k+1
		if left(f.name,Len(strKey))=strKey Or Len(Trim(strKey))=0 then k=k+1
	next
	getFileCount=k
End Function
 
'创建文件
'fileName  文件路径和文件名组成
'content	文件内容
'Return		文件生成
function createFile(fileName,content) 
	Dim fso
	Set fso = CreateObject("scripting.filesystemobject")
	Set myfile=fso.CreateTextFile( fileName,,ture)
	str=Split(content, VbCrlf)
	content=""
	For Each i In str
	myfile.WriteLine i
	Next 
	myfile.Close
end function 
 
'删除文件中的关键字或者某行
Function DeleteLine(strFile, strKey, LineNumber, CheckCase)
	'DeleteLine Function by TomRiddle 2008
 
	'Remove line(s) containing text (strKey) from text file (strFile)
	'or
	'Remove line number from text file (strFile)
	'or
	'Remove line number if containing text (strKey) from text file (strFile)
 
	'Use strFile = "c:\file.txt" (Full path to text file)
	'Use strKey = "John Doe" (Lines containing this text string to be deleted)
	'Use strKey = "" (To not use keyword search)
	'Use LineNumber = "1" (Enter specific line number to delete)
	'Use LineNumber = "0" (To ignore line numbers)
	'Use CheckCase = "1" (For case sensitive search )
	'Use CheckCase = "0" (To ignore upper/lower case characters)
 
 
	Const ForReading=1:Const ForWriting=2
	Dim objFSO,objFile,Count,strLine,strLineCase,strNewFile
	Set objFSO=CreateObject("Scripting.FileSystemObject")
	Set objFile=objFSO.OpenTextFile(strFile,ForReading)
	Do Until objFile.AtEndOfStream
		strLine=objFile.Readline
		If CheckCase=0 then strLineCase=ucase(strLine):strKey=ucase(strKey)
		If LineNumber=objFile.Line-1 or LineNumber=0 then
			If instr(strLine,strKey) or instr(strLineCase,strkey) or strKey="" then
				strNewFile=strNewFile
			Else
				strNewFile=strNewFile&strLine&vbcrlf
			End If
		Else
			strNewFile=strNewFile&strLine&vbcrlf
		End If
	Loop
	objFile.Close
	Set objFSO=CreateObject("Scripting.FileSystemObject")
	Set objFile=objFSO.OpenTextFile(strFile,ForWriting)
	objFile.Write strNewFile
	objFile.Close
End Function 
 
'获取文件的MD5值
'Function MD5Sum(filename)
' 	Dim MyStream, MyHashed, MD5Value
'    Set MyStream = CreateObject("ADODB.Stream")
'    MyStream.Type = 1
'    MyStream.Open()
'    MyStream.LoadFromFile(filename)
'    Set MyHashed = CreateObject("CAPICOM.HashedData")
'    MyHashed.Algorithm = 3
'    MyHashed.Hash(MyStream.Read())
'    MyStream.Close
'    MD5Value = MyHashed.Value
'    MD5Sum = MD5Value
'End Function
 
'获取文件的MD5值
'fileName	文件路径和文件名组成
'Return		返回文件的MD5值，大写的
Function getFileMD5(fileName)
	Dim file_hash
	Dim hash_value
	Dim i,wi
	Set wi = CreateObject("WindowsInstaller.Installer")
	Set file_hash = wi.FileHash(fileName, 0)
	hash_value = ""
	For i = 1 To file_hash.FieldCount
		hash_value = hash_value & BigEndianHex(file_hash.IntegerData(i))
	Next
	getFileMD5 = hash_value
	Set file_hash = Nothing
	Set wi = Nothing
End Function
 
 
Function BigEndianHex(Int)
	Dim result
	Dim b1, b2, b3, b4
	result = Hex(Int)
	b1 = Mid(result, 7, 2)
	b2 = Mid(result, 5, 2)
	b3 = Mid(result, 3, 2)
	b4 = Mid(result, 1, 2)
	BigEndianHex = b1 & b2 & b3 & b4
End Function
 
 
'使用文件选择框选择文件
Function BrowseForFile()
	BrowseForFile=CreateObject("WScript.Shell").Exec("mshta vbscript:""""").StdOut.ReadAll
End Function
 
'获取文件的所在目录
'fileName  文件路径和文件名组成
function getFilePath(fileName)
	getFilePath=Left(fileName,InStrRev(fileName,"\")-1)
end function 
 
'删除文件
function deleteFile(fileName)
	set fso=createobject("scripting.filesystemobject")
	REM 如果不存在也不要提示
	if (fso.FileExists(fileName)) then
		fso.deleteFile fileName
	End if
end function 
 
'压缩文件成rar格式
'rar.exe a test.rar test.txt
'rarName  rar文件路径和文件名组成
'target_dir  源文件路径
'fileName  文件名组成
Function rarFiles(rarPath,rarName,target_dir,fileName)
	SET ws=CreateObject("wscript.shell")
	'set fso=CreateObject("scripting.filesystemobject")
	'ws.run "cd "&target_dir,0
	ws.currentdirectory=target_dir
	rarPath=chr(34)&rarPath&chr(34)
	'在这里修改文件名，注意不要含有空格
	ws.run rarPath&" a "&rarName&" "&fileName,0
End Function