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,創(chuàng)建新文件夾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"
小生今天上網(wǎng)下載了一個財務常用報表的文件包，里面有幾百個excel工作表，要是手工一個一個的獲得文件名的話，那我可是要忙十天半月哦。于是想到昨論壇就是vba論壇，昨不充分利用excel 自身的高級應用呀，呵呵，實現(xiàn)的代碼如下，把工作量幾天的任務可是一下子就完成了，這就是excel vba給你工作提高效率的結(jié)果！
excle vba自動獲取同一文件夾下所有工作表的名稱紅色代碼：
按Alt+F11，打開VBA編輯器，插入一個模塊，把下面的代碼貼進去，按F5執(zhí)行
Sub t()
Dim s As FileSearch '定義一個文件搜索對象
Set s = Application.FileSearch
s.LookIn = "c：\" '注意路徑，換成你實際的路徑
s.Filename = "*.*" '搜索所有文件
s.Execute '執(zhí)行搜索
Cells.Delete '表格清空
For i = 1 To s.FoundFiles.Count
Cells(i, 1) = s.FoundFiles(i) '每一行第一列填寫一個文件名
Next
End Sub
現(xiàn)在獲得的可是帶路徑的工作表名，去掉前的路徑可用以下方法；
=RIGHT(A1,LEN(A1)-FIND("#",SUBSTITUTE(A1,"\","#",LEN(A1)-LEN(SUBSTITUTE(A1,"\",)))))
最后用常規(guī)的方法往下拖，就完成了筆者所需的工作表名。
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 = #
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
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 '創(chuàng)建表格
Set cnnaccess =CreateObject("Adodb.Connection")
Set rstAnswers =CreateObject("Adodb.Recordset")
cnnaccess.Provider ="Microsoft.Jet.OLEDB.4.0"
Application.Wait Now() + TimeValue("00：00：02") '系統(tǒng)暫停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
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 '執(zhí)行搜索
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
2009-08-20 00：07
vba操作文件及文件夾示例
利用excel中的vba可以對電腦中的文件及文件夾做一些常用的操作。
包括復制、重命名、刪除等，其中一些簡單的示例總結(jié)如下。
希望對一些經(jīng)常需要批量處理文件的朋友有所幫助，也希望感興趣的朋友多多指教！以下代碼建議在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,創(chuàng)建新文件夾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 函數(shù)遍歷文件夾下的所有文件
2010-05-26 17：30
第 1.12例 Dir函數(shù)
一、題目：
要求編寫一段代碼，運用Dir函數(shù)返回一個文件夾的文件列表。
二、代碼：
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聲明為可變型數(shù)據(jù)類型。
3、wjm = Dir("C：\WINDOWS\WIN.ini") ：
如果該文件存在則返回“WIN.INI”(在C：\Windows 文件夾中) ，把返回的文件名賦給變量wjm 。如果該文件不存在則wjm=””。
4、wjm = Dir("C：\WINDOWS\*.ini") ：
返回帶指定擴展名的文件名。如果超過一個 *.ini 文件存在，函數(shù)將返回按條件第一個找到的文件名。
5、wjm = Dir ：
若第二次調(diào)用 Dir 函數(shù)，但不帶任何參數(shù)，則函數(shù)將返回同一目錄下的下一個 *.ini 文件。
Dir函數(shù)
返回一個字符串 String，用以表示一個文件名、目錄名或文件夾名稱，它必須與指定的模式或文件屬性、或磁盤卷標相匹配。
Dir[(pathname[, attributes])]
Dir 函數(shù)的語法具有以下幾個部分：
pathname 可選參數(shù)。用來指定文件名的字符串表達式，可能包含目錄或文件夾、以及驅(qū)動器。如果沒有找到 pathname，則會返回零長度字符串 ("")。
attributes 可選參數(shù)。常數(shù)或數(shù)值表達式，其總和用來指定文件屬性。如果省略，則會返回匹配 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 ‘下一個文件
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
如果我們要在Excel中獲取某個文件夾中所有的文件列表，可以通過下面的VBA代碼來進行。代碼運行后，首先彈出一個瀏覽文件夾對話框，然后新建一個工作簿，并在工作表的A至F列分別列出選定文件夾中的所有文件的文件名、文件大小、創(chuàng)建時間、修改時間、訪問時間及完整路徑。方法如下：
1.按Alt+F11，打開VBA編輯器，單擊菜單“插入→模塊”，將下面的代碼粘貼到右側(cè)的代碼窗口中：
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
'獲取文件的詳細信息，并放到數(shù)組中
ReDim myResults(0 To UBound(varFileList) +1, 0 To 5)
myResults(0, 0) = "文件名"
myResults(0, 1) = "大小（字節(jié)）"
myResults(0, 2) = "創(chuàng)建時間"
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
' 如果文件夾中包含文件返回一個二維數(shù)組，否則返回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$()
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”，單擊“運行”按鈕。
已經(jīng)解決了，新的代碼
---------------------------------------------
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
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
'【自定義函數(shù)】
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
幾種實現(xiàn)代碼：
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
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
'【自定義函數(shù)】
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中測試通過
Sub qd_name_del() '刪除啟動查找目錄及文件
'On Error Resume Next '忽略錯誤,如果有錯誤發(fā)生就執(zhí)行下一語句
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可以對電腦中的文件及文件夾做一些常用的操作。包括復制、重命名、刪除等，其中一些簡單的示例總結(jié)如下。 希望對一些經(jīng)常需要批量處理文件的朋友有所幫助，也希望感興趣的朋友多多指教！
以下代碼建議在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,創(chuàng)建新文件夾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"
Dim fso 'As Object
Set fso = CreatObject(“Scripting. FileSystemObject”)
fso.CreateFolder(foldername)
不過運行不了......
Set fso = CreatObject(“Scripting. FileSystemObject”)
提示這一句有錯......
但是如果文件夾已經(jīng)存在了會出錯
那怎么判斷一個文件夾存不存在？
Dim fso As New FileSystemObject
if fso.FolderExists folderName then
msgbox "文件夾已存在！ "
else
fso.CreateFolder(foldername)
end if
FileSystemObject 不能用的話,在工程里添加一下引用"microsoft Scripting runtime "
Dim fso As New FileSystemObject
if fso.FolderExists folderName then
msgbox "文件夾已存在！ "
else
fso.CreateFolder(foldername)
end if
FileSystemObject 不能用的話,在工程里添加一下引用"microsoft Scripting runtime "
如果指定的文件夾存在，則返回True；否則返回 False。
object.FolderExists(folderspec)
參數(shù)
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
利用excel中的vba可以對電腦中的文件及文件夾做一些常用的操作。包括復制、重命名、刪除等，其中一些簡單的示例總結(jié)如下。希望對一些經(jīng)常需要批量處理文件的朋友有所幫助，也希望感興趣的朋友多多指教！
以下代碼建議在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,創(chuàng)建新文件夾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"
MkDir 語句示例
本示例使用 MkDir 語句來創(chuàng)建目錄或文件夾。如果沒有指定驅(qū)動器，新目錄或文件夾將會建在當前驅(qū)動器中。
MkDir "MYDIR" ' 建立新的目錄或文件夾。
MkDir "C：\Temp"''在C盤根目錄下新一個名為Temp的文件夾.
MkDir必須逐級建立文件夾,或者說它的上一級目錄必須存在后才能建議,不能跨級建立,如
MkDir "C：\Temp\Test",如果C盤Temp目錄不存在時,將出現(xiàn)錯誤.
聯(lián)系客服
