VBA文件及文件夹操作

1.VBA操作文件及文件夹

on error resume next下测试

A，在D：\下新建文件夹，命名为folder

方法1：MkDir "D：\folder"

方法2：Set abc =CreateObject("Scripting.FileSystemObject")

abc.CreateFolder ("D：\folder")

B，新建2个文件命名为a.xls和b.xls

Workbooks.Add

ActiveWorkbook.SaveAs Filename：="D：\folder\a.xls"

ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"

C,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xls

MkDir "D：\folder1"

FileCopy "D：\folder\a.xls", "D：\folder1\c.xls"

D,复制folder中所有文件到folder1

Set qqq =CreateObject("Scripting.FileSystemObject")

qqq.CopyFolder "D：\folder", "D：\folder1"

D,重命名a.xls为d.xls

name "d：\folder1\a.xls" as "d：\folder1\d.xls"

E,判断文件及文件夹是否存在

Set yyy =CreateObject("Scripting.FileSystemObject")

If yyy.FolderExists("D：\folder1) = True Then ...

If yyy.FileExists("D：\folder1\d.xls) = True Then ...

F,打开folder1中所有文件

Set rrr =CreateObject("Scripting.FileSystemObject")

Set r = rrr.GetFolder("d：\folder1")

For Each i In r.Files

Workbooks.Open Filename：=("d：\folder1\" + i.Name +"")

Next

G,删除文件c.xls

kill "d：\folder1\c.xls"

H,删除文件夹folder

Set aaa = CreateObject("Scripting.FileSystemObject")

aaa.DeleteFolder "d：\folder"

2.excel vba一次性获取文件夹下的所有文件名的方法

小生今天上网下载了一个财务常用报表的文件包，里面有几百个excel工作表，要是手工一个一个的获得文件名的话，那我可是要忙十天半月哦。于是想到昨论坛就是vba论坛，昨不充分利用excel 自身的高级应用呀，呵呵，实现的代码如下，把工作量几天的任务可是一下子就完成了，这就是excel vba给你工作提高效率的结果！

excle vba自动获取同一文件夹下所有工作表的名称红色代码：

按Alt+F11，打开VBA编辑器，插入一个模块，把下面的代码贴进去，按F5执行

Sub t()

Dim s As FileSearch '定义一个文件搜索对象

Set s = Application.FileSearch

s.LookIn = "c：\" '注意路径，换成你实际的路径

s.Filename = "*.*" '搜索所有文件

s.Execute '执行搜索

Cells.Delete '表格清空

For i = 1 To s.FoundFiles.Count

Cells(i, 1) = s.FoundFiles(i) '每一行第一列填写一个文件名

Next

End Sub

现在获得的可是带路径的工作表名，去掉前的路径可用以下方法；

=RIGHT(A1,LEN(A1)-FIND("#",SUBSTITUTE(A1,"\","#",LEN(A1)-LEN(SUBSTITUTE(A1,"\",)))))

最后用常规的方法往下拖，就完成了笔者所需的工作表名。

outlook下VBA编程：把公用文件夹里的邮件附件拷贝出来保存在硬盘上

2009-06-17 09：35

Sub SaveAttachments()

Dim oApp As Outlook.Application

Dim oNameSpace As NameSpace

Dim oFolder As MAPIFolder

Dim oMailItem As Object

Dim sMessage As String

BeforeDate = #10/1/2007#     ' choose the end date of wanted

MyDir = "E：\liuxc-work\oil loss\backup frompublic folder\"   ' choose thefolder location for save

Sender = "Hz121 Supervisor"   ' caution, case sensitive

SendFile = "HZ121-1_Daily.xls"

MyY = 0

Set oApp = New Outlook.Application

Set oNameSpace =oApp.GetNamespace("MAPI")

Set oFolder = oNameSpace.PickFolder

For Each oMailItem In oFolder.Items

With oMailItem

MyT3 = Left(CStr(oMailItem.CreationTime),10)

If CDate(oMailItem.CreationTime) >=BeforeDate Then

If oMailItem.SenderName = Sender Then

If oMailItem.Attachments.Count > 0 Then' protect error

For i = 1 To oMailItem.Attachments.Count

If oMailItem.Attachments.Item(i).FileName =SendFile Then

MyT1 = InStr(1,oMailItem.Attachments.Item(i).FileName, ".", 1)

MyT2 =Left(oMailItem.Attachments.Item(i).FileName, 19) + "-" + MyT3 +".xls"

oMailItem.Attachments.Item(i).SaveAsFileMyDir & MyT2

MsgBoxoMailItem.Attachments.Item(i).DisplayName & " was saved as "& oMailItem.Attachments.Item(i).FileName

End If

Next i

End If

End If

Else

MyY = MyY + 1

If MyY > 10 Then GoTo LoopEnd

End If

End With

Next oMailItem

LoopEnd：

' Set oMailItem = Nothing

' Set oFolder = Nothing

' Set oNameSpace = Nothing

' Set oApp = Nothing

3.Excel VBA把选定文件夹中的工作簿导入到新建ACCESS数据库中

2010-04-24 22：33

方法一

Sub Create_AccessProject()

Dim AccessData As Object

Set AccessData = CreateObject("Access.Application")

Dim Stpath As String

Stpath = ThisWorkbook.Path &"\DSEM-Stock-Allocation.mdb" '设定路径

If Dir(Stpath, vbDirectory) ="DSEM-Stock-Allocation.mdb" Then

Kill (Stpath)

End If

AccessData.NewCurrentDatabase Stpath

Set AccessData = Nothing '创建表格

Set cnnaccess =CreateObject("Adodb.Connection")

Set rstAnswers =CreateObject("Adodb.Recordset")

cnnaccess.Provider ="Microsoft.Jet.OLEDB.4.0"

Application.Wait Now() + TimeValue("00：00：02") '系统暂停2秒,以等待data.mdb建立成功

cnnaccess.Open "Data Source ="& Stpath & ";Jet OLEDB：Database Password=" & ""

'strSQL = "Create TablemyData(last_date char(8))"

'rstAnswers.Open strSQL, cnnaccess

Set rstAnswers = Nothing

Set cnnaccess = Nothing

MyMainFile = ThisWorkbook.Name

Dim CurFile As String

Application.DisplayAlerts = False

myFile =Application.GetOpenFilename("(*.xls),*.xls)", , "Please SelectFiles")

If myFile = False Then Exit Sub

DirLoc = CurDir(myFile) & "\"

CurFile = Dir(DirLoc &"*.xls")

Do While CurFile <> vbNullString

Set objAccess = CreateObject("Access.Application")

LinkFile = DirLoc & CurFile

TableName = Left(CurFile, Len(CurFile) - 4)

If CurFile ="HONHAI-VMIData1.xls" Then

With objAccess

.OpenCurrentDatabase (ThisWorkbook.Path& "\DSEM-Stock-Allocation.mdb")

.DoCmd.TransferSpreadsheet acLink, 8, TableName,LinkFile, True, "Aging Report$"

End With

objAccess.CloseCurrentDatabase

Set objAccess = Nothing

CurFile = Dir

Else

With objAccess

.OpenCurrentDatabase (ThisWorkbook.Path& "\DSEM-Stock-Allocation.mdb")

.DoCmd.TransferSpreadsheet acImport, 8,TableName, LinkFile, True, ""

End With

objAccess.CloseCurrentDatabase

Set objAccess = Nothing

CurFile = Dir

End If

Loop

End Sub

方法二

Sub Folder2Access()

Dim db As DAO.Database

Dim ws As DAO.Workspace

Set ws = DBEngine.Workspaces(0)

Set db = ws.OpenDatabase("C：\CustomersDataBase\DSEM-PO-Stock-Status.mdb",False, False, "")

db.Execute ("delete * from[DSEM-MovingPlan]")

db.Close

Set db = Nothing

Dim myFile As String

Dim s As FileSearch '定义一个文件搜索对象

Set s = Application.FileSearch

s.LookIn = "C：\CustomersDataBase\Test\" '注意路径，换成你实际的路径

s.Filename = "*.*" '搜索所有文件

s.Execute '执行搜索

For i = 1 To s.FoundFiles.Count

FullName1 = Right(s.FoundFiles(i),Len(s.FoundFiles(i)) - Len("C：\CustomersDataBase\Test\"))

Filename = Left(FullName1, Len(FullName1) -4)

Set objAccess =CreateObject("Access.Application")

myFile = "C：\CustomersDataBase\Test\"& Filename & ".xls"

With objAccess

.OpenCurrentDatabase ("C：\CustomersDataBase\DSEM-PO-Stock-Status.mdb")

.DoCmd.TransferSpreadsheet acImport, 8,"DSEM-MovingPlan", myFile, True, ""

End With

objAccess.CloseCurrentDatabase

Set objAccess = Nothing

Next

End Sub

4.vba操作文件及文件夹示例

2009-08-20 00：07

vba操作文件及文件夹示例

利用excel中的vba可以对电脑中的文件及文件夹做一些常用的操作。

包括复制、重命名、删除等，其中一些简单的示例总结如下。

希望对一些经常需要批量处理文件的朋友有所帮助，也希望感兴趣的朋友多多指教！以下代码建议在on error resume next下测试

1，在D：\下新建文件夹，命名为folder

方法1：MkDir "D：\folder"

方法2：Set abc =CreateObject("Scripting.FileSystemObject")

abc.CreateFolder ("D：\folder")

2，新建2个文件命名为a.xls和b.xls

Workbooks.Add

ActiveWorkbook.SaveAs Filename：="D：\folder\a.xls"

ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"

3,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xls

MkDir "D：\folder1"

FileCopy "D：\folder\a.xls", "D：\folder1\c.xls"

4,复制folder中所有文件到folder1

Set qqq =CreateObject("Scripting.FileSystemObject")

qqq.CopyFolder "D：\folder", "D：\folder1"

5,重命名a.xls为d.xls

name "d：\folder1\a.xls" as "d：\folder1\d.xls"

6,判断文件及文件夹是否存在

Set yyy =CreateObject("Scripting.FileSystemObject")

If yyy.FolderExists("D：\folder1) = True Then ...

If yyy.FileExists("D：\folder1\d.xls) = True Then ...

7,打开folder1中所有文件

Set rrr =CreateObject("Scripting.FileSystemObject")

Set r = rrr.GetFolder("d：\folder1")

For Each i In r.Files

Workbooks.Open Filename：=("d：\folder1\" + i.Name +"")

Next 8,删除文件c.xls

kill "d：\folder1\c.xls" 9,删除文件夹folder

Set aaa =CreateObject("Scripting.FileSystemObject")

aaa.DeleteFolder "d：\folder"

VBA Dir 函数遍历文件夹下的所有文件

2010-05-26 17：30

5.VBA Dir函数

第 1.12例 Dir函数

一、题目：

要求编写一段代码，运用Dir函数返回一个文件夹的文件列表。

二、代码：

Sub 示例_1_12()

Dim wjm

wjm = Dir("C：\WINDOWS\WIN.ini")

MsgBox wjm

wjm = Dir("C：\WINDOWS\*.ini")

wjm = Dir

End Sub

三、代码详解

1、Sub 示例_1_12()：宏程序的开始语句。宏名为示例_1_12。

2、Dim wjm ：变量wjm声明为可变型数据类型。

3、wjm = Dir("C：\WINDOWS\WIN.ini")  ：

如果该文件存在则返回“WIN.INI”(在C：\Windows 文件夹中) ，把返回的文件名赋给变量wjm 。如果该文件不存在则wjm=””。

4、wjm = Dir("C：\WINDOWS\*.ini")  ：

返回带指定扩展名的文件名。如果超过一个 *.ini 文件存在，函数将返回按条件第一个找到的文件名。

5、wjm = Dir  ：

若第二次调用 Dir 函数，但不带任何参数，则函数将返回同一目录下的下一个 *.ini 文件。

Dir函数

返回一个字符串 String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。

Dir[(pathname[, attributes])]

Dir 函数的语法具有以下几个部分：

pathname        可选参数。用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串 ("")。

attributes        可选参数。常数或数值表达式，其总和用来指定文件属性。如果省略，则会返回匹配 pathname 但不包含属性的文件。

EXCEL的VBA用于同时显示目录文件夹和文件列表

2010-05-22 18：41

”VBA工具中要引用microsoft scipting runtime

Dim pt As Range

Sub 查找文件夹下子文件夹及其大小()

Dim theDir As String

Set pt = ActiveSheet.Range("a1")

pt.Worksheet.Columns(1).ClearContents   '清除第一列

theDir = Application.InputBox      ("输入指定文件夹的路径：", "查看子文件夹及其大小")

pt = theDir                  ‘列出选取的目录名

listPath theDir            ’用于列出子目录和文件

pt.Worksheet.Columns("a：b").AutoFit

End Sub

Sub listPath(strDir As String)

Dim thePath As String

Dim strSdir As String

Dim theDirs As Scripting.Folders

Dim theDir As Scripting.Folder

Dim row As Integer

Dim s As String

Dim myFso As Scripting.FileSystemObject

Set myFso = New Scripting.FileSystemObject

If Right(strDir, 1) <> "\"Then strDir = strDir & "\"

thePath = thePath & strDir

row = pt.row             '此段为获取此目录下的文件名

s = Dir(thePath, 7)      '获取第一个文件

Do While s <> ""

row = row + 1

Cells(row, 1) = s    '文件的名称

Cells(row, 1).Font.Color = RGB(256, 12,213)

Cells(row, 1).Font.Bold = Ture

s = Dir                                  ‘下一个文件

Loop

Set pt = Cells(row, 1)

Set pt = pt.Offset(1, 0)

Set theDirs = myFso.getfolder(strDir).subfolders

For Each theDir In theDirs

pt = theDir.Path

pt.Next = theDir.Size

listPath theDir.Path

Next

Set myFso = Nothing

End Sub

Private Sub CommandButton1_Click()

查找文件夹下子文件夹及其大小

End Sub

6.用VBA获取文件夹中的文件列表

如果我们要在Excel中获取某个文件夹中所有的文件列表，可以通过下面的VBA代码来进行。代码运行后，首先弹出一个浏览文件夹对话框，然后新建一个工作簿，并在工作表的A至F列分别列出选定文件夹中的所有文件的文件名、文件大小、创建时间、修改时间、访问时间及完整路径。方法如下：

1.按Alt+F11，打开VBA编辑器，单击菜单“插入→模块”，将下面的代码粘贴到右侧的代码窗口中：

Option Explicit

Sub GetFileList()

Dim strFolder As String

Dim varFileList As Variant

Dim FSO As Object, myFile As Object

Dim myResults As Variant

Dim l As Long

'显示打开文件夹对话框

WithApplication.FileDialog(msoFileDialogFolderPicker)

.Show

If .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹

strFolder = .SelectedItems(1)

End With

'获取文件夹中的所有文件列表

varFileList = fcnGetFileList(strFolder)

If Not IsArray(varFileList) Then

MsgBox "未找到文件", vbInformation

Exit Sub

End If

'获取文件的详细信息，并放到数组中

ReDim myResults(0 To UBound(varFileList) +1, 0 To 5)

myResults(0, 0) = "文件名"

myResults(0, 1) = "大小（字节）"

myResults(0, 2) = "创建时间"

myResults(0, 3) = "修改时间"

myResults(0, 4) = "访问时间"

myResults(0, 5) = "完整路径"

Set FSO =CreateObject("Scripting.FileSystemObject")

For l = 0 To UBound(varFileList)

Set myFile =FSO.GetFile(CStr(varFileList(l)))

myResults(l + 1, 0) = CStr(varFileList(l))

myResults(l + 1, 1) = myFile.Size

myResults(l + 1, 2) = myFile.DateCreated

myResults(l + 1, 3) =myFile.DateLastModified

myResults(l + 1, 4) =myFile.DateLastAccessed

myResults(l + 1, 5) = myFile.Path

Next l

fcnDumpToWorksheet myResults

Set myFile = Nothing

Set FSO = Nothing

End Sub

Private Function fcnGetFileList(ByValstrPath As String, Optional strFilter As String) As Variant

' 如果文件夹中包含文件返回一个二维数组，否则返回False

Dim f As String

Dim i As Integer

Dim FileList() As String

If strFilter = "" Then strFilter= "*.*"

Select Case Right$(strPath, 1)

Case "\", "/"

strPath = Left$(strPath, Len(strPath) - 1)

End Select

ReDim Preserve FileList(0)

f = Dir$(strPath & "\" &strFilter)

Do While Len(f) > 0

ReDim Preserve FileList(i) As String

FileList(i) = f

i = i + 1

f = Dir$()

Loop

If FileList(0) <> Empty Then

fcnGetFileList = FileList

Else

fcnGetFileList = False

End If

End Function

Private Sub fcnDumpToWorksheet(varData AsVariant, Optional mySh As Worksheet)

Dim iSheetsInNew As Integer

Dim sh As Worksheet, wb As Workbook

Dim myColumnHeaders() As String

Dim l As Long, NoOfRows As Long

If mySh Is Nothing Then

'新建一个工作簿

iSheetsInNew =Application.SheetsInNewWorkbook

Application.SheetsInNewWorkbook = 1

Set wb = Application.Workbooks.Add

Application.SheetsInNewWorkbook =iSheetsInNew

Set sh = wb.Sheets(1)

Else

Set mySh = sh

End If

With sh

Range(.Cells(1, 1), .Cells(UBound(varData,1) + 1, UBound(varData, 2) + 1)) = varData

.UsedRange.Columns.AutoFit

End With

Set sh = Nothing

Set wb = Nothing

End Sub

2.关闭VBA编辑器，回到Excel工作表中，按Alt+F8，打开“宏”对话框，选择“GetFileList”，单击“运行”按钮。

7.VBA中如何取文件的最后修改时间?

已经解决了，新的代码

---------------------------------------------

Sub searchfiles()

With Application.FileSearch

.NewSearch

.LookIn = "D：\ttt"

.Filename = "*.xls"

.SearchSubFolders = True

.FileType = msoFileTypeAllFiles

If .Execute() > 0 Then

For i = 1 To .FoundFiles.Count

Worksheets("sheet3").Cells(i,2).Value = .FoundFiles(i)

Dim fs, f, s

Set fs =CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFile(.FoundFiles(i))

s = "Created： " & f.DateCreated

Worksheets("sheet3").Cells(i,3).Value = s

Set f = Nothing

Set fs = Nothing

Next i

Else

MsgBox "no file found."

End If

End With

End Sub

8.VBA代码调用浏览文件夹对话框的几种方法

2009-05-25 15：24

1、使用API方法

'【类型声明】

Private Type BROWSEINFO

hWndOwner      As Long

pIDLRoot       As Long

pszDisplayName As Long

lpszTitle      As Long

ulFlags        As Long

lpfnCallback   As Long

lParam         As Long

iImage         As Long

End Type

'【API声明】

Private Declare FunctionSHGetPathFromIDList Lib "shell32.dll" _

Alias "SHGetPathFromIDListA"(ByVal pidl As Long, _

ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolderLib "shell32.dll" _

Alias "SHBrowseForFolderA"(lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function lstrcat Lib"kernel32" _

Alias "lstrcatA" (ByVal lpString1As String, _

ByVal lpString2 As String) As Long

Private Declare Function OleInitialize Lib"ole32.dll" _

(lp As Any) As Long

Private Declare Sub OleUninitialize Lib"ole32" ()

Private Const BIF_USENEWUI = &H40

Private Const MAX_PATH = 260

'【自定义函数】

Public Function GetFolder_API(sTitle AsString, Optional vFlags As Variant) As String

Dim lpIDList As Long

Dim sBuffer As String

Dim BInfo As BROWSEINFO

If IsMissing(vFlags) Then vFlags =BIF_USENEWUI

Call OleInitialize(ByVal 0&)

With BInfo

.lpszTitle = lstrcat(sTitle, "")

.ulFlags = vFlags

End With

lpIDList = SHBrowseForFolder(BInfo)

If (lpIDList) Then

sBuffer = Space(MAX_PATH)

SHGetPathFromIDList lpIDList, sBuffer

sBuffer = Left(sBuffer, InStr(sBuffer,vbNullChar) - 1)

If sBuffer <> "" ThenGetFolder_API = sBuffer

End If

Call OleUninitialize

End Function

'【使用方法】

Sub Test()

MsgBox GetFolder_API("选择文件夹")

End Sub

2、使用Shell.Application方法

Sub GetFloder_Shell()

Set objShell =CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(0,"选择文件夹",0, 0)

If Not objFolder Is Nothing Then

MsgBox objFolder.self.path

End If

Set objFolder = Nothing

Set objShell = Nothing

End Sub

3、使用FileDialog方法

Sub GetFloder_FileDialog()

Dim fd As FileDialog

Set fd =Application.FileDialog(msoFileDialogFolderPicker)

If fd.Show = -1 Then MsgBoxfd.SelectedItems(1)

Set fd = Nothing

End Sub

以上方法在WINXP+OFFICE2003中测试通过

Excel VBA选择目标文件夹方法

2009-04-13 08：49

9.用VBA选择目标文件夹

几种实现代码：

1.FileDialog 属性

Sub Sample1()

WithApplication.FileDialog(msoFileDialogFolderPicker)

If .Show = True Then

MsgBox .SelectedItems(1)

'txtFolder.Text = .SelectedItems(1)

End If

End With

End Sub

2.shell 方法

Sub Sample2()

Dim Shell, myPath

Set Shell =CreateObject("Shell.Application")

Set myPath = Shell.BrowseForFolder(&O0,"请选择文件夹",&H1 + &H10, "G：\")

If Not myPath Is Nothing Then MsgBoxmyPath.Items.Item.Path

Set Shell = Nothing

Set myPath = Nothing

End Sub

3.API 方法

Declare Function SHGetPathFromIDList Lib"shell32.dll" Alias "SHGetPathFromIDListA" _

(ByVal pidl As Long, ByVal pszPath AsString) As Long

Declare Function SHBrowseForFolder Lib"shell32.dll" Alias "SHBrowseForFolderA" _

(lpBrowseInfo As BROWSEINFO) As Long

Declare Function GetDesktopWindow Lib"user32" () As Long

Public Type BROWSEINFO

hOwner As Long

pidlRoot As Long

pszDisplayName As String

lpszTitle As String

ulFlags As Long

lpfn As Long

lParam As Long

iImage As Long

End Type

Sub Sample3()

Dim buf As String

buf = GetFolder("请选择文件夹")

If buf = "" Then Exit Sub

MsgBox buf

End Sub

Function GetFolder(Optional Msg) As String

Dim bInfo As BROWSEINFO, pPath As String

Dim R As Long, X As Long, pos As Integer

bInfo.pidlRoot = 0&

bInfo.lpszTitle = Msg

bInfo.ulFlags = &H1

X = SHBrowseForFolder(bInfo)

pPath = Space$(512)

R = SHGetPathFromIDList(ByVal X, ByValpPath)

If R Then

pos = InStr(pPath, Chr$(0))

GetFolder = Left(pPath, pos - 1)

Else

GetFolder = ""

End If

End Function

10.VBA代码调用浏览文件夹对话框的几种方法

1、使用API方法

'【类型声明】

Private Type BROWSEINFO

hWndOwner      As Long

pIDLRoot       As Long

pszDisplayName As Long

lpszTitle      As Long

ulFlags        As Long

lpfnCallback   As Long

lParam         As Long

iImage         As Long

End Type

'【API声明】

Private Declare FunctionSHGetPathFromIDList Lib "shell32.dll" _

Alias "SHGetPathFromIDListA"(ByVal pidl As Long, _

ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolderLib "shell32.dll" _

Alias "SHBrowseForFolderA"(lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function lstrcat Lib"kernel32" _

Alias "lstrcatA" (ByVal lpString1As String, _

ByVal lpString2 As String) As Long

Private Declare Function OleInitialize Lib"ole32.dll" _

(lp As Any) As Long

Private Declare Sub OleUninitialize Lib"ole32" ()

Private Const BIF_USENEWUI = &H40

Private Const MAX_PATH = 260

'【自定义函数】

Public Function GetFolder_API(sTitle AsString, Optional vFlags As Variant) As String

Dim lpIDList As Long

Dim sBuffer As String

Dim BInfo As BROWSEINFO

If IsMissing(vFlags) Then vFlags =BIF_USENEWUI

Call OleInitialize(ByVal 0&)

With BInfo

.lpszTitle = lstrcat(sTitle, "")

.ulFlags = vFlags

End With

lpIDList = SHBrowseForFolder(BInfo)

If (lpIDList) Then

sBuffer = Space(MAX_PATH)

SHGetPathFromIDList lpIDList, sBuffer

sBuffer = Left(sBuffer, InStr(sBuffer,vbNullChar) - 1)

If sBuffer <> "" ThenGetFolder_API = sBuffer

End If

Call OleUninitialize

End Function

'【使用方法】

Sub Test()

MsgBox GetFolder_API("选择文件夹")

End Sub

2、使用Shell.Application方法

Sub GetFloder_Shell()

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder(0,"选择文件夹",0, 0)

If Not objFolder Is Nothing Then

MsgBox objFolder.self.path

End If

Set objFolder = Nothing

Set objShell = Nothing

End Sub

3、使用FileDialog方法

Sub GetFloder_FileDialog()

Dim fd As FileDialog

Set fd =Application.FileDialog(msoFileDialogFolderPicker)

If fd.Show = -1 Then MsgBoxfd.SelectedItems(1)

Set fd = Nothing

End Sub

以上方法在WINXP+OFFICE2003中测试通过

11.VBA 操作，删除，新建文件夹

Sub qd_name_del()   '删除启动查找目录及文件

'On Error Resume Next  '忽略错误,如果有错误发生就执行下一语句

Set fs =CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFolder("C：\Documents andSettings\winxp")

f.Delete

End Sub

简单就是

CreateObject("scripting.filesystemobject").getfolder(strpathname).Delete

利用excel中的vba可以对电脑中的文件及文件夹做一些常用的操作。包括复制、重命名、删除等，其中一些简单的示例总结如下。 希望对一些经常需要批量处理文件的朋友有所帮助，也希望感兴趣的朋友多多指教！

以下代码建议在onerror resume next下测试 1，在D：\下新建文件夹，命名为folder方法1：MkDir "D：\folder" 方法2：Set abc = CreateObject("Scripting.FileSystemObject")abc.CreateFolder ("D：\folder")

2，新建2个文件命名为a.xls和b.xls Workbooks.AddActiveWorkbook.SaveAs Filename：="D：\folder\a.xls" ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"

3,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xlsMkDir "D：\folder1"FileCopy "D：\folder\a.xls","D：\folder1\c.xls"

4,复制folder中所有文件到folder1Set qqq = CreateObject("Scripting.FileSystemObject") qqq.CopyFolder"D：\folder","D：\folder1"

5,重命名a.xls为d.xls name"d：\folder1\a.xls"as "d：\folder1\d.xls"

6,判断文件及文件夹是否存在

Set yyy =CreateObject("Scripting.FileSystemObject")

If yyy.FolderExists("D：\folder1) = True

Then ... If yyy.FileExists("D：\folder1\d.xls) = True

Then ...

7,打开folder1中所有文件 Set rrr = CreateObject("Scripting.FileSystemObject") Setr = rrr.GetFolder("d：\folder1") For Each i In r.Files Workbooks.Open Filename：=("d：\folder1\" + i.Name +"") Next

8,删除文件c.xls kill "d：\folder1\c.xls"

9,删除文件夹folder Set aaa =CreateObject("Scripting.FileSystemObject") aaa.DeleteFolder "d：\folder"

12.可以通过控件或者代码新建一个文件夹吗？

Dim  fso   'As   Object

Set  fso   =   CreatObject(“Scripting.   FileSystemObject”)

fso.CreateFolder(foldername)

不过运行不了......

Set  fso   =   CreatObject(“Scripting.   FileSystemObject”)

提示这一句有错......

但是如果文件夹已经存在了会出错

那怎么判断一个文件夹存不存在？

Dim  fso     As   New  FileSystemObject

if  fso.FolderExists    folderName   then

msgbox  "文件夹已存在！ "

else

fso.CreateFolder(foldername)

end  if

FileSystemObject   不能用的话,在工程里添加一下引用"microsoft   Scripting   runtime "

13.怎么判断一个文件夹存不存在？

Dim  fso     As   New  FileSystemObject

if  fso.FolderExists    folderName   then

msgbox  "文件夹已存在！ "

else

fso.CreateFolder(foldername)

end  if

FileSystemObject   不能用的话,在工程里添加一下引用"microsoft   Scripting   runtime "

14.FolderExists 方法

如果指定的文件夹存在，则返回True；否则返回 False。

object.FolderExists(folderspec)

参数

object

必选项。应为FileSystemObject 的名称。

folderspec

必选项。文件夹名称，表示要确定是否存在的文件夹。如果该文件夹不在当前文件夹中，则必须提供完整路径名（绝对路径或相对路径）。

说明

下面例子举例说明如何使用FolderExists 方法：

Function ReportFolderStatus(fldr)

Dim fso, msg

Set fso =CreateObject("Scripting.FileSystemObject")

If (fso.FolderExists(fldr)) Then

msg = fldr & " 存在。"

Else

msg = fldr & " 不存在。"

End If

ReportFolderStatus = msg

End Function

15.vba操作文件及文件夹示例

利用excel中的vba可以对电脑中的文件及文件夹做一些常用的操作。包括复制、重命名、删除等，其中一些简单的示例总结如下。希望对一些经常需要批量处理文件的朋友有所帮助，也希望感兴趣的朋友多多指教！

以下代码建议在onerror resume next下测试

1，在D：\下新建文件夹，命名为folder

方法1：

MkDir "D：\folder"

方法2：

Set abc =CreateObject("Scripting.FileSystemObject") abc.CreateFolder ("D：\folder")

2，新建2个文件命名为a.xls和b.xls

Workbooks.Add ActiveWorkbook.SaveAsFilename：="D：\folder\a.xls"ActiveWorkbook.SaveAs Filename：="D：\folder\b.xls"

3,创建新文件夹folder1并把a.xls复制到新文件夹重新命名为c.xlsMkDir "D：\folder1"FileCopy "D：\folder\a.xls","D：\folder1\c.xls"

4,复制folder中所有文件到folder1Set qqq = CreateObject("Scripting.FileSystemObject") qqq.CopyFolder"D：\folder","D：\folder1"

5,重命名a.xls为d.xls name"d：\folder1\a.xls"as "d：\folder1\d.xls"

6,判断文件及文件夹是否存在

Set yyy =CreateObject("Scripting.FileSystemObject")

If yyy.FolderExists("D：\folder1) = True

Then ... If yyy.FileExists("D：\folder1\d.xls) = True

Then ...

7,打开folder1中所有文件 Set rrr = CreateObject("Scripting.FileSystemObject") Setr = rrr.GetFolder("d：\folder1") For Each i In r.Files Workbooks.Open Filename：=("d：\folder1\" + i.Name +"") Next

8,删除文件c.xls kill "d：\folder1\c.xls"

9,删除文件夹folder Set aaa =CreateObject("Scripting.FileSystemObject") aaa.DeleteFolder "d：\folder"

16.用VBA新建文件夹

MkDir 语句示例

本示例使用 MkDir 语句来创建目录或文件夹。如果没有指定驱动器，新目录或文件夹将会建在当前驱动器中。

MkDir "MYDIR"     ' 建立新的目录或文件夹。

MkDir "C：\Temp"''在C盘根目录下新一个名为Temp的文件夹.

MkDir必须逐级建立文件夹,或者说它的上一级目录必须存在后才能建议,不能跨级建立,如

MkDir "C：\Temp\Test",如果C盘Temp目录不存在时,将出现错误.