[寄存]VBS对文件文件夹操作的例子

返回总目录  

原作者：we似曾相识
原地址：http://bbs./thread-208704-1-1.html

//=====================<VBS对文件夹操作例子>
(1)创建文件夹

CODE:

Dim fso, f
'如果指定的文件夹已经存在，则会出现错误。
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateFolder("c:\New Folder")(2)删除文件夹

CODE:

Dim fso,filespec
filespec="D:\电影" '要删除的文件夹路径
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFolder(filespec)
'若删除只读文件夹则将上一行改为fso.DeleteFolder(filespec,true)(3)判断文件夹是否存在

CODE:

Dim fso,msg,tt
Set fso = CreateObject("Scripting.FileSystemObject")
fldr="C:\Documents and Settings" '文件夹路径和名字
tt = fso.FolderExists(fldr) '存在返回true;不存在返回false
If tt=true Then
msg = fldr & " 存在。"
Else
msg = fldr & " 不存在。"
End If
Msgbox msg
(4)获取指定目录下所有文件的文件名(不包含文件夹名)

CODE:

Dim a
a="D:\文件夹1"     '目标文件夹完整路径
Msgbox ShowFolderList(a)
Function ShowFolderList(folderspec)
    Dim fso, f, f1, fc, s    '定义变量
    Set fso = CreateObject("Scripting.FileSystemObject") '创建对象
    Set f = fso.GetFolder(folderspec)  '得到文件夹下folder对象
    Set fc = f.Files
    For Each f1 in fc   '查找所有符合条件的文件名
        s = s & f1.name
        s = s & vbcrlf    '得到结果并换行
    Next
    ShowFolderList = s
End Function
(5)分离路径中的文件名(不带扩展名)

CODE:

Msgbox GetTheBase("C:\tt.txt")  'GetTheBase返回值tt
Function GetTheBase(filespec)
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
  GetTheBase = fso.GetBaseName(filespec)
End Function//=====================<VBS对文件操作例子>
(1)创建文件

CODE:

Dim fso, MyFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile("c:\123.txt", True) 'true则可以覆盖已有的同名文件
Msgbox "这是一个测试"
MyFile.Close  'close是必要的,不要省
(2)删除文件

CODE:

Dim fso,filespec
filespec="C:\123.txt" '要删除的文件
'设置成"C:\*.doc"则删除C目录下所有.doc扩展名的文档(但不会删除其子文件夹下.doc文档)
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(filespec)
'若删除只读文件则将上一行改为fso.DeleteFile(filespec,true)(3)判断文件是否存在

CODE:

Dim fso,msg,tt
Set fso = CreateObject("Scripting.FileSystemObject")
fle="C:\123.txt" '文件的完整路径
tt = fso.FileExists(fle) '存在返回true;不存在返回false
If tt=true Then
msg = fle & " 存在。"
Else
msg = fle & " 不存在。"
End If
Msgbox msg
(4)创建快捷方式的例子

CODE:

'用CreateObject的方法开启WshShell
Set WshShell=CreateObject("WScript.Shell")
'制定文件夹为桌面
strDesKtop=WshShell.SpecialFolders("DesKtop")
'在制定文件夹创建"画笔.lnk"快捷方式
Set oShellLink=WshShell.CreateShortcut(strDesKtop&"\画图.lnk")
'制定快捷方式指向的目标程序
oShellLink.TargetPath="mspaint.exe"
'制定风格
oShellLink.WindowStyle=1
'制定热键
oShellLink.Hotkey="CTRL+SHIFT+P"
'制定图标
oShellLink.IconLocation="mspaint.exe,0"
'注释快捷方式
oShellLink.Description="有标准VBS建立的画笔快捷方式"
'制定工作目录
oShellLink.WorkingDirectory=strDesKtop
'保存快捷方式
oShellLink.Save
(5)获取文件创建访问等信息

CODE:

Msgbox FileInfor("C:\b.txt")
  Function FileInfor(FilePath)
  Dim fso, f, s ,a
  Set fso = CreateObject("Scripting.FileSystemObject")
  a=FilePath  '文件完整路径
  Set f = fso.GetFile(a)
  s = f.Path & vbcrlf
  s = s & "创建时间: " & f.DateCreated & vbcrlf  
  s = s & "访问时间: " & f.DateLastModified & vbcrlf
  s = s & "修改时间: " & f.DateLastAccessed
  ShowFileAccessInfo = s
  FileInfor = s
  End Function(6)VBS获取特定文件路径

CODE:

Set wshell = CreateObject("WScript.Shell")
PathDesktop = wshell.specialfolders("Desktop")
MsgBox PathDesktop&"=桌面 的绝对路径"
PathFavorites = wshell.specialfolders("Favorites")
MsgBox PathFavorites&"=收藏夹 的绝对路径"
PathFonts = wshell.specialfolders("Fonts")
MsgBox PathFonts&"=字体 的绝对路径"
PathMyDocuments = wshell.specialfolders("MyDocuments")
MsgBox PathMyDocuments&"=我的文档 的绝对路径"
PathNetHood = wshell.specialfolders("NetHood")
MsgBox PathNetHood&"=网上邻居 的绝对路径"
PathPrintHood = wshell.specialfolders("PrintHood")
MsgBox PathPrintHood&"=打印机 的绝对路径"
PathPrograms = wshell.specialfolders("Programs")
MsgBox PathPrograms&"=程序 的绝对路径"
PathRecent = wshell.specialfolders("Recent")
MsgBox PathRecent&"=最近文档 的绝对路径"
PathSendTo = wshell.specialfolders("SendTo")
MsgBox PathSendTo&"=发送到 的绝对路径"
PathStartMenu = wshell.specialfolders("StartMenu")
MsgBox PathStartMenu&"=开始菜单 的绝对路径"
PathStartUp = wshell.specialfolders("StartUp")
MsgBox PathStartUp&"=启动 的绝对路径"
PathTemplates = wshell.specialfolders("Templates")
MsgBox PathTemplates&"=模板 的绝对路径"(7)复制文件到其他目录

CODE:

Dim sPath, tPath
sPath="C:\tt.txt"
tPath="D:\tt.txt"
set fso=CreateObject("Scripting.FileSystemObject")
fso.CopyFile sPath, tPath  '将C:\tt.txt复制到D盘
(8)将某文件夹下所有指定格式文件拷贝到其他目录

CODE:

Const OverwriteExisting = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile "C:\*.txt" , "D:\" ,OverwriteExisting
VBS读取、修改.INI文件键值
(1)VBS读取.INI文件键值

CODE:

Msgbox ReadINI("C:\123.ini","c","timeout")  '输入的小节或键名不存在则返回为空
Function ReadINI(FilePath,Bar,PrimaryKey)
Dim fso,sReadLine,i,j,ss
Set fso=CreateObject("Scripting.FileSystemObject")
Set INIfile=fso.opentextfile(FilePath,1)
do until INIfile.atendofstream
    sReadLine=INIfile.readline
If sReadLine="" then
    INIfile.skipline
ElseIf Trim(sReadLine)="["& Bar &"]" then '找到小节名
    '查找该小节名下的键名
    Do until INIfile.atendofstream
    sReadLine=INIfile.readline  '读取小节名后的行
    j=instr(sReadLine,"=")
    If j>0 then   '小节名后的文本行存在
       If instr(Left(sReadLine,j),PrimaryKey)>0 then  '从"="左边字符串找到键名
          ss = Trim(Right(sReadLine,len(sReadLine)-instr(sReadLine,"=")))         
          Exit do
       Else
          INIfile.skipline  '没找到键名跳过此行
       End If
    Else
       INIfile.skipline
    End If
    Loop
Else
End If
loop
INIfile.close
Set fso=nothing
ReadINI = ss
End Function
(2)VBS修改.INI文件键值

CODE:

Call WriteINI("C:\123.ini","c","timeout", "abcdef")
'上面一行是调用方法
Function WriteINI(FilePath, Bar, PrimaryKey, Value)
On Error Resume Next
Const ForReading=1
Const ForWriting=2
Const ForAppending=8
Dim fso, sRead, i, j, sReadLine, BE, stxt
Set fso=CreateObject("Scripting.FileSystemObject")
Set ForRead=fso.opentextfile(FilePath,1)
Dim a()  '文本内容逐行放入数组
i=0
j=0
BE=0
sRead=ForRead.ReadAll
ForRead.close
If Instr(sRead,"[")=0 then  '说明INI文件没有主键,那么写入主键和键值即可
    Set ForWrite=fso.opentextfile(FilePath,2)
    ForWrite.WriteLine "["& Bar &"]"
    ForWrite.WriteLine PrimaryKey &"="& Value
Else
    Dim sArray
    sArray=split(sRead,"[")
        For i=1 to UBound(sArray)
           If Left(sArray(i),Len(Bar))=Bar then '小节名存在
                 If Instr(sArray(i),PrimaryKey)>0 then  '找到键名
                     Set ForRead=fso.opentextfile(FilePath,1)
                     Do Until ForRead.AtEndOfStream
                     sReadLine = ForRead.ReadLine
                     If Instr(sReadLine,"["& Bar &"]")>0 then
                        While Instr(sReadLine,PrimaryKey)+0<0  '读到键名为止
                           Msgbox sReadLine
                           sReadLine = ForRead.ReadLine
                        Wend
                        stxt = Right(sReadLine,Len(sReadLine)-Left(sReadLine,instr(sReadLine,"=")))
                        Exit do
                     End If
                     Loop
                     sArray(i)=Replace(sArray(i), stxt, Value) '将键值替换为Value
                 Else
                     sArray(i)=Replace(sArray(i),Bar&"]",Bar&"]"& vbcrlf & PrimaryKey &"="& Value)
                 End If
                 BE=1
           Else
           End If
        Next
        If BE=1 then 'BE=1说明小节名存在,用数组配置好了键名与键值
           ForRead.close
           Set ForWrite=fso.opentextfile(FilePath,2) '覆盖原有内容重新写入
           ForWrite.Write ""
           ForWrite.close
           Set ForWrite=fso.opentextfile(FilePath,8) '清空并追加写入内容
           i=0
           For i=1 to UBound(sArray)
           ForWrite.Write "["& sArray(i)
           Next
           ForWrite.close
           Set fso=nothing
           Exit Function
        End If
        ForRead.close   '写入小节名和键值
        Set ForWrite=fso.opentextfile(FilePath,8)
        ForWrite.WriteLine "["& Bar &"]"
        ForWrite.WriteLine PrimaryKey &"="& Value
End If
ForWrite.close
Set fso=nothing
End Function
//===============<得到文件、文件夹字节数>
[VBS得到目标文件字节数]

CODE:

Function ShowFileSize(filespec)
    Dim fso, f, s
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFile(filespec)
s = UCase(f.Name) & " 大小为 " & f.size & " 字节。"
ShowFileSize = s
End Function[VBS得到目标文件夹下所有文件的字节数]

CODE:

Function ShowFolderSize(filespec)
    Dim fso, f, s
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(filespec)
s = UCase(f.Name) & " 大小为 " & f.size & " 字节。"
ShowFolderSize = s
End Function
//===============<得到文件、文件夹类型>
[VBS得到目标文件类型信息]

CODE:

Function ShowFileType(filespec)
    Dim fso, f, s
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFile(filespec)
    s = UCase(f.Name) & " 的类型为 " & f.Type
ShowFileType = s
End Function
[VBS得到目标文件类型信息]

CODE:

Function ShowFolderType(filespec)
    Dim fso, f, s
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(filespec)
    s = UCase(f.Name) & " 的类型为 " & f.Type
ShowFolderType = s
End Function
//===============<读取文本内容>
[读取文本全部内容、读取文本行]

CODE:

set ttfile=fso.opentextfile(f,forappending)
'读取打开文件的一行并回车(下次读从下一行开始)
read=ttfile.ReadLine
'读取所有文件内容
read=ttfile.ReadAll
[读取文本返回行数, 指定行内容]

CODE:

n=inputbox("请输入要读取的第n行","提示")
set fso=createobject("scripting.filesystemobject")
set j=fso.opentextfile("c:\??.txt")
i=0
do until j.atendofstream
h=j.readline
i=i+1
loop
msgbox "共有"&i&"行"
j.close
i=0
set j=fso.opentextfile("c:\??.txt")
do until j.atendofstream
h=j.readline
i=i+1
if i=n then
msgbox "第"&n&"行为"&h
end if
loop
j.close
[倒序输出文本行内容]

CODE:

Dim arrFileLines()
i = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("C:\tt.txt", 1)
Do
    Redim Preserve arrFileLines(i)
    arrFileLines(i) = objFile.ReadLine
    i = i + 1
Loop Until objFile.AtEndOfStream
objFile.Close
For l = Ubound(arrFileLines) to LBound(arrFileLines) Step -1
    Wscript.Echo arrFileLines(l)
Next.
[获取指定文件的文件名、文件扩展名、完整文件路径等等]

CODE:

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile("按键精灵.rar")
Wscript.Echo "Absolute path: " & objFSO.GetAbsolutePathName(objFile)
Wscript.Echo "Parent folder: " & objFSO.GetParentFolderName(objFile)
Wscript.Echo "File name: " & objFSO.GetFileName(objFile)
Wscript.Echo "Base name: " & objFSO.GetBaseName(objFile)
Wscript.Echo "Extension name: " & objFSO.GetExtensionName(objFile)
[解压缩文件夹]

CODE:

strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colFolders = objWMIService.ExecQuery ("Select * from Win32_Directory where name = 'c:\\Scripts'")
For Each objFolder in colFolders
    errResults = objFolder.Uncompress
    Wscript.Echo errResults
Next
[枚举文件夹属性、详细信息]
'返回字节数、目录、文件夹名称、文件夹创建访问修改时间、路径、所在驱动盘等

CODE:

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\新建文件夹")
Wscript.Echo "Date created: " & objFolder.DateCreated  '创建时间
Wscript.Echo "Date last accessed: " & objFolder.DateLastAccessed  '最后访问时间
Wscript.Echo "Date last modified: " & objFolder.DateLastModified  '最后修改时间
Wscript.Echo "Drive: " & objFolder.Drive  '所在磁盘
Wscript.Echo "Is root folder: " & objFolder.IsRootFolder  '判断文件夹是否是根文件夹,返回true/false
Wscript.Echo "Name: " & objFolder.Name  '所在文件夹
Wscript.Echo "Parent folder: " & objFolder.ParentFolder  '父文件夹对象
Wscript.Echo "Path: " & objFolder.Path  '路径
Wscript.Echo "Short name: " & objFolder.ShortName  '短文件名
Wscript.Echo "Short path: " & objFolder.ShortPath  '短路径
Wscript.Echo "Size: " & objFolder.Size     '文件大小M
Wscript.Echo "Type: " & objFolder.Type     '字节B

[检索计算机上所有隐藏文件夹路径]

CODE:

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
    ("Select * from Win32_Directory Where Hidden = True")
For Each objFile in colFiles
    Wscript.Echo objFile.Name
Next[检索Dll插件版本信息]

CODE:

Set objFSO = CreateObject("Scripting.FileSystemObject")
Wscript.Echo objFSO.GetFileVersion("c:\windows\system32\scrrun.dll")
[去掉指定文件夹下文件或子文件夹的只读属性]

CODE:

CreateObject("WScript.Shell").Run "cmd /c attrib -r 指定目录 /s /d",0
[修改文件、文件夹属性为隐藏或显示]

CODE:

Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile("C:\a.txt")
f.Attributes = f.Attributes - 2  ' - 2 隐藏, + 2 显示
//============<遍历用户桌面文件夹、文件>
'[1] 遍历当前用户(不全)桌面文件

CODE:

Const DESKTOP = &H10&
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(DESKTOP)
Set objFolderItem = objFolder.Self
Set colItems = objFolder.Items
For Each objItem in colItems
    Txt = Txt & objItem.Name & vbcrlf
Next
Msgbox Txt, 64+4096, "结果"
Set objFolderItem = nothing
Set objFolder = nothing
Set objShell = nothing'
'[2] 遍历所有用户桌面文件
本帖隐藏的内容需要回复才可以浏览'
'[3] 获取桌面路径，GetFolder方法遍历子文件夹、文件

CODE:

Set wshell = CreateObject("WScript.Shell")
PathDesktop = wshell.specialfolders("Desktop")'得到桌面的绝对路径
Dim fso, fc
Set fso = CreateObject("Scripting.FileSystemObject")
Set fs = fso.GetFolder(PathDesktop).SubFolders '遍历子文件夹
SK = vbcrlf & "[文件夹]" & vbcrlf
For Each fls In fs
    SK = SK & fls.Name & vbcrlf
Next
Set fc = fso.GetFolder(PathDesktop).Files '遍历文件夹下的文件
CK = vbcrlf & "[文件]" & vbcrlf
For Each flc In fc
    CK = CK & flc.Name & vbcrlf
Next
txt = SK & CK
Msgbox txt, 64+4096, "结果"
Set wshell = nothing//============<遍历盘符，递归遍历子目录>

'[1] 遍历计算机磁盘名称

CODE:

Set fso=CreateObject("scripting.filesystemobject")
Set objdrives = fso.Drives
For Each objdrive In objdrives '遍历磁盘
TracePrint objdrive
Next'[2]递归遍历指定目录下所有子目录(遍历目标文件夹下所有文件夹、子文件夹路径)

CODE:

Msgbox 递归遍历所有子目录("D:\")
Function 递归遍历所有子目录(目录)
    VBSBegin
        Function GetSubFolders(sPath)
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set sFolder = fso.GetFolder(sPath)
            Set subFolderSet = sFolder.SubFolders
            For Each subFolder in subFolderSet
                'MsgBox "subFolder.Path=" & subFolder.Path
                GetSubFolders = subFolder.Path & vbcrlf & GetSubFolders(subFolder.Path) &  GetSubFolders
            Next
        End Function
    VBSEnd
    递归遍历所有子目录=GetSubFolders(目录)
End Function'[3]递归遍历指定目录下所有子目录(遍历目标文件夹下所有文件夹、子文件夹路径)

CODE:

Dim AddStr
VBSBegin
    Function RecSv(CurrentPath) '递归
        Set ABC=CurrentPath.subfolders
        For Each GGMM In ABC
            Set TmpCk=fso.GetFolder(GGMM.path)
            AddStr = AddStr & vbcrlf & TmpCk.path
            Call RecSv(TmpCk)
        Next
        RecSv = AddStr
    End function
VBSEnd
Set fso=CreateObject("scripting.filesystemobject")
Set SxE=fso.GetFolder("C:\Program Files")
msgbox RecSv(SxE)