vbs脚本：文件操做.vbs

'全局对象 
Set fso=createobject("scripting.filesystemobject")  
Set shell = CreateObject ("Wscript.Shell")

Rem : =========== 启动主程序 
Dim starttime , Endtime

starttime = Now 
WriteLog vbNullString
WriteLog "========================================"
WriteLog "Script start at : " & starttime
Call main()
Endtime = Now 
WriteLog "Script end at : " & Endtime
WriteLog "========================================"
WriteLog vbNullString
Set fso = Nothing 






Rem :  =========== 主程序
Sub main()
End Sub 







Rem :  ===========  将信息写入日志文件
Rem :  ===========  在脚本所在的目录下建立以脚本名称+日期为名称的txt文件
Rem :  ===========  会自动在写入的每条日志前加上日期时间
Sub WriteLog(strmsg)
	
    Dim logtxt
    logtxt = WScript.ScriptFullName & "_" & Date & ".txt"
    
    Dim f 
    If fso.fileexists(logtxt) Then 
        Set f = fso.opentextfile(logtxt, 8 )
    Else
        Set f = fso.opentextfile(logtxt, 2, true)
    End If 

    f.writeline Now & " : " &strmsg 
    f.close 
    Set f = Nothing 

    Wscript.Sleep 5    
End Sub 




Rem :  ===========  打开浏览器，选中指定文件或文件夹
Rem :  ===========  文件或文件夹必须存在
Sub ExplorerSel(path)
	Dim f
	f = Trim( path )
	If Right(f,1) = "/" Then f = Left(f,Len(f) -1 )
	If fso.fileexists(f) = False And fso.folderexists(f) = False Then Err.Raise vbObjectError+128, "ExplorerSel", f & " does not exists"

    
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	shell.Run "explorer.exe /select," & Chr(34) & f & Chr(34),1,TRUE
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "ExplorerSel", errMsg & vbNewLine & _
								"                path:" & vbTab & path
		Exit Sub
	End If

End Sub




Rem :  ===========  写入多行文本，会覆盖文件中已有的内容
Rem :  ===========  文件必须存在
Rem :  ===========  text 中能够是单行，也能够是多行文本，
Sub WriteText( file, text )
	Dim f
	f = Trim( file )
	If Right(f,1) = "/" Then f = Left(f,Len(f) -1 )
	If fso.fileexists(f) = False Then Err.Raise vbObjectError+128, "WriteText", f & " does not exists"

	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	Const ForReading = 1, ForWriting = 2
	Dim fi
	Set fi = fso.OpenTextFile(f, ForWriting, True)
	fi.Write text
	fi.close
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "WriteText", errMsg & vbNewLine & _
								"                file:" & vbTab & file & vbNewLine & _
								"                text:" & vbTab & text
		Exit Sub
	End If

End Sub






Rem :  ===========  追加单行文本，文件不存在建立文件
Rem :  ===========  文件必须存在
Rem :  ===========  line 中能够是单行，也能够是多行文本，
Sub AppendLine( file, line )
	Dim f
	f = Trim( file )
	If Right(f,1) = "/" Then f = Left(f,Len(f) -1 )
	If fso.fileexists(f) = False Then Err.Raise vbObjectError+128, "AppendLine", f & " does not exists"

	
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	const forappending = 8
	set objtextfile = fso.opentextfile (file, forappending, true)
	objtextfile.writeline(line)
	objtextfile.close
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "AppendLine", errMsg & vbNewLine & _
								"                file:" & vbTab & file & vbNewLine & _
								"                line:" & vbTab & line
		Exit Sub
	End If

End Sub





Rem :  ===========  显示选择文件对话框，返回文件路径
Rem :  ===========  取消则返回空字符串
Function SelectfileDialog( )

	Set objDialog = CreateObject("UserAccounts.CommonDialog") 
	objDialog.Filter = "All Files|*.*" 
	objDialog.InitialDir = "C:/" 
	intResult = objDialog.ShowOpen 
	If intResult = 0 Then 
		SelectfileDialog = vbNullString
	Else 
		SelectfileDialog = objDialog.FileName 
	End If
End Function




Rem :  ===========  复制文本到剪贴板
Sub SetTextToClipboard( text )
	Set objIE = CreateObject("InternetExplorer.Application") 
	objIE.Navigate("about:blank") 
	objIE.document.parentwindow.clipboardData.SetData "text", text 
	objIE.Quit
End Sub




Rem :  ===========  文件是否存在
Function FileExists( path )
	FileExists = fso.fileexists(path)
End Function




Rem :  ===========  文件夹是否存在
Function FolderExists( path )
	FolderExists = fso.FolderExists(path)
End Function




Rem :  ===========  删除文件
Rem :  ===========  文件必须存在
Sub DeleteFile( file )
	If fso.fileexists(file) = false Then Err.Raise vbObjectError+128, "DeleteFile", "File : " & file & "  does not exist"
    
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
    fso.deletefile file, True
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "DeleteFile", errMsg & vbNewLine & _
								"                file:" & vbTab & file
		Exit Sub
	End If

End Sub




Rem :  ===========  删除文件夹，无论是否为空
Rem :  ===========  文件夹必须存在
Sub DeleteFolder( folder )
	Dim f1
	f1 = folder
	If Right(folder,1) = "/" Then f1 = Left(folder,Len(folder) -1 )
	If fso.folderexists(f1)=False Then Err.Raise vbObjectError+128, "DeleteFolder", "Folder : " & f1 & " does not exist"
	 
    
    Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
    fso.DeleteFolder f1, True
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "DeleteFolder", errMsg & vbNewLine & _
								"                folder:" & vbTab & folder
		Exit Sub
	End If
End Sub




Rem :  ===========  将文件 file 移动到文件夹 folder 中，至关于剪切操做
Rem :  ===========  file必须存在
Rem :  ===========  folder必须存在且属性不能为只读
Rem :  ===========  foler中不能存在与file同名的文件或文件夹
Sub MoveFile( file, folder )
	Dim f1, f2
	f1 = file
	f2 = folder
	If Right(f1,1) = "/" Then f1 = Left(f1,Len(f1) -1 )
	If Right(f2,1) = "/" Then f2 = Left(f2,Len(f2) -1 )

	If fso.fileexists(f1)=False Then
		Err.Raise vbObjectError+128, "MoveFile", "File : " & f1 & " does not exist"
	End If
	If fso.folderexists(f2)=False Then
		Err.Raise vbObjectError+128, "MoveFile", "Folder : " & f2 & " does not exist"
	End If
	
	Dim f
	f = f2 & "/" & fso.GetFileName(f1)
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then
		Err.Raise vbObjectError+128, "MoveFile", f & " already exists"
	End If
	
	Dim errMsg
	On Error Resume Next
	fso.MoveFile  f1, f2 & "/"
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "MoveFile", errMsg & vbNewLine & _
								"                file:" & vbTab & file & vbNewLine & _
								"                folder:" & vbTab & folder
		Exit Sub
	End If	
End Sub




Rem :  ===========  将文件夹 folder1 移动到文件夹 folder2 中
Rem :  ===========  folder1必须存在
Rem :  ===========  folder2必须存在且属性不能为只读
Rem :  ===========  foler2中不能存在与folder1同名的文件或文件夹
Sub MoveFolder( folder1, folder2 )
	Dim f1, f2
	f1 = folder1
	f2 = folder2
	If Right(folder1,1) = "/" Then f1 = Left(folder1,Len(folder1) -1 )
	If Right(folder2,1) = "/" Then f2 = Left(folder2,Len(folder2) -1 )
	If fso.folderexists(f1)=False Then Err.Raise vbObjectError+128, "MoveFolder", "Folder : " & f1 & " does not exist"
	If fso.folderexists(f2)=False Then Err.Raise vbObjectError+128, "MoveFolder", "Folder : " & f2 & " does not exist"
	
	f = f2 & "/" & fso.GetBaseName(f1)
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then
		Err.Raise vbObjectError+128, "MoveFolder", f & " already exists"
		Exit Sub
	End If
	
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	' 同一分区，移动
	If fso.GetDriveName(f1) <> vbNullString And fso.GetDriveName(f1) = fso.GetDriveName(f2) Then
		fso.MoveFolder f1, f2 & "/"
	' 不一样分区，复制后删除
	Else
		fso.CopyFolder f1, f2 & "/", False
		fso.DeleteFolder f1, True
	End If
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "MoveFolder", errMsg & vbNewLine & _
								"                folder1:" & vbTab & folder1 & vbNewLine & _
								"                folder2:" & vbTab & folder2
		Exit Sub
	End If
	End Sub




Rem :  ===========  将文件 file 复制到文件夹 folder 中
Rem :  ===========  file必须存在
Rem :  ===========  folder必须存在且属性不能为只读
Rem :  ===========  foler中不能存在与file同名的文件或文件夹
Sub CopyFile( file, folder )
	Dim f1, f2
	f1 = file
	f2 = folder
	If Right(f1,1) = "/" Then f1 = Left(f1,Len(f1) -1 )
	If Right(f2,1) = "/" Then f2 = Left(f2,Len(f2) -1 )

	If fso.fileexists(f1)=False Then
		Err.Raise vbObjectError+128, "CopyFile", "File : " & f1 & " does not exist"
	End If
	If fso.folderexists(f2)=False Then
		Err.Raise vbObjectError+128, "CopyFile", "Folder : " & f2 & " does not exist"
	End If
	
	Dim f
	f = f2 & "/" & fso.GetFileName(f1)
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then
		Err.Raise vbObjectError+128, "CopyFile", f & " already exists"
	End If
	
	Dim errMsg
	On Error Resume Next
	fso.CopyFile f1, f2 & "/", False
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "CopyFile", errMsg & vbNewLine & _
								"                file:" & vbTab & file & vbNewLine & _
								"                folder:" & vbTab & folder
		Exit Sub
	End If
End Sub




Rem :  ===========  将文件夹 folder1 复制到文件夹 folder2 中
Rem :  ===========  folder1必须存在
Rem :  ===========  folder2必须存在且属性不能为只读
Rem :  ===========  foler2中不能存在与folder1同名的文件或文件夹
Sub CopyFolder( folder1, folder2 )
	Dim f1, f2
	f1 = folder1
	f2 = folder2
	If Right(folder1,1) = "/" Then f1 = Left(folder1,Len(folder1) -1 )
	If Right(folder2,1) = "/" Then f2 = Left(folder2,Len(folder2) -1 )
	If fso.folderexists(f1)=False Then Err.Raise vbObjectError+128, "CopyFolder", "Folder : " & f1 & " does not exist"
	If fso.folderexists(f2)=False Then Err.Raise vbObjectError+128, "CopyFolder", "Folder : " & f2 & " does not exist"
	
	f = f2 & "/" & fso.GetBaseName(f1)
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then
		Err.Raise vbObjectError+128, "CopyFolder", f & " already exists"
		Exit Sub
	End If
	
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	fso.CopyFolder f1, f2 & "/", False
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "CopyFolder", errMsg & vbNewLine & _
								"                folder1:" & vbTab & folder1 & vbNewLine & _
								"                folder2:" & vbTab & folder2
		Exit Sub
	End If
End Sub



Rem :  ===========  得到文件名，不包括路径部分
Rem :  ===========  file 必须存在
Function GetFileName( file )
	If fso.fileexists(file)=False Then Err.Raise vbObjectError+128, "GetFileName", "File : " & file & " does not exist"
	
	Dim errMsg
	On Error Resume Next
	'  ===========  code begin
	GetFileName = fso.GetFileName(file)
	'  ===========  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "GetFileName", errMsg & vbNewLine & _
								"                file:" & vbTab & file
		Exit function
	End If
End function







Rem :  ===========  将文件 file 从新命名，路径不变，名称为 newName
Rem :  ===========  file 必须存在
Rem :  ===========  newName 只能是文件名，不能包含路径信息
Rem :  ===========  newName 不能是 file 所在目录中已有的文件或文件夹 
Sub RenameFile( file, newName )
	If fso.fileexists(file) = false Then Err.Raise vbObjectError+128, "RenameFile", "File : " & file & "  does not exist"
	If Len(fso.getfilename(newName)) <> Len(newName) Then Err.Raise vbObjectError+128, "RenameFile", newName & " contains path info"

	Dim f
	f = fso.GetParentFolderName(file)
	If Right(f,1) <> "/" Then f = f & "/"
	f = f & newName
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then Err.Raise vbObjectError+128, "RenameFile", f & " already exists"
	
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
		fso.MoveFile file, f
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "RenameFile", errMsg & vbNewLine & _
								"                file:" & vbTab & file & vbNewLine & _
								"                newName:" & vbTab & newName
		Exit Sub
	End If
End Sub







Rem :  ===========  将文件加 folder 从新命名，路径不变，名称为 newFolder
Rem :  ===========  folder 必须存在
Rem :  ===========  newName 只能是文件夹名称，不能包含路径信息
Rem :  ===========  newName 不能是 folder 所在目录中已有的文件或文件夹 
Sub RenameFolder( folder, newName )
	If fso.FolderExists(folder) = false Then Err.Raise vbObjectError+128, "RenameFolder", "Folder : " & folder & "  does not exist"
	If Len(fso.getfilename(newName)) <> Len(newName) Then Err.Raise vbObjectError+128, "RenameFolder", newName & " contains path info"
	
	Dim f
	f = fso.GetParentFolderName(folder)
	If Right(f,1) <> "/" Then f = f & "/"
	f = f & newName
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then Err.Raise vbObjectError+128, "RenameFolder", f & " already exists"

	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	fso.MoveFolder folder, f
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "RenameFolder", errMsg & vbNewLine & _
								"                folder:" & vbTab & folder & vbNewLine & _
								"                newName:" & vbTab & newName
		Exit Sub
	End If
End Sub







Rem :  ===========  建立文件夹
Rem :  ===========  不能有同名的文件或文件夹
Rem :  ===========  父文件夹必须存在
Sub CreateFolder( folder )
	Dim f
	f = Trim( folder )
	If Right(f,1) = "/" Then f = Left(f,Len(f) -1 )
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then Err.Raise vbObjectError+128, "CreateFolder", f & " already exists"
	If fso.folderexists(fso.GetParentFolderName(f)) = False Then Err.Raise vbObjectError+128, "CreateFolder", fso.GetParentFolderName(f) & " does not exists"
	
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	fso.CreateFolder f
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "CreateFolder", errMsg & vbNewLine & _
								"                folder:" & vbTab & folder
		Exit Sub
	End If
End Sub







Rem :  ===========  建立文本文件
Rem :  ===========  不能有同名的文件或文件夹
Rem :  ===========  父文件夹必须存在
Sub CreateTextFile( file )
	Dim f
	f = Trim( file )
	If Right(f,1) = "/" Then f = Left(f,Len(f) -1 )
	If fso.fileexists(f) = True Or fso.folderexists(f) = True Then Err.Raise vbObjectError+128, "CreateFolder", f & " already exists"
	If fso.folderexists(fso.GetParentFolderName(f)) = False Then Err.Raise vbObjectError+128, "CreateFolder", fso.GetParentFolderName(f) & " does not exists"
	
	Dim errMsg
	On Error Resume Next
	Rem  ======  code begin
	fso.CreateTextFile f, false
	Rem  ======  code end
	If Err.Number <> 0 Then
		errMsg = Err.Description
		On Error Goto 0
		Err.Raise vbObjectError+128, "CreateTextFile", errMsg & vbNewLine & _
								"                file:" & vbTab & file 
		Exit Sub
	End If
End Sub







'Rem :  ===========  注释
'Sub {FunctionName}( {par1}, {par2} )
'	If {condition} Then Err.Raise vbObjectError+128, "{FunctionName}", "Error Description"
'	If {condition} Then Err.Raise vbObjectError+128, "{FunctionName}", "Error Description"
	
'	Dim errMsg
'	On Error Resume Next
'	Rem  ======  code begin
'	Rem  ======  code end
'	If Err.Number <> 0 Then
'		errMsg = Err.Description
'		On Error Goto 0
'		Err.Raise vbObjectError+128, "{FunctionName}", errMsg & vbNewLine & _
'								"                {par1}:" & vbTab & {par1} & vbNewLine & _
'								"                {par2}:" & vbTab & {par2}
'		Exit Sub
'	End If
'End Sub