VBA文件及文件夾操作--精選文檔

1、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.xlsWorkbooks.AddActiveWorkbook.SaveAs Filename：="D：foldera.xls"Acti

2、veWorkbook.SaveAs Filename：="D：folderb.xls"C,創(chuàng)建新文件夾folder1并把a.xls復(fù)制到新文件夾重新命名為c.xlsMkDir "D：folder1"FileCopy "D：foldera.xls", "D：folder1c.xls"D,復(fù)制folder中所有文件到folder1Set qqq = CreateObject("Scripting.FileSystemObject")qqq.CopyFolder "D：folder"

3、;, "D：folder1"D,重命名a.xls為d.xlsname "d：folder1a.xls" as "d：folder1d.xls"E,判斷文件及文件夾是否存在Set yyy = CreateObject("Scripting.FileSystemObject")If yyy.FolderExists("D：folder1) = True Then .If yyy.FileExists("D：folder1d.xls) = True Then .F,打開folder1中所有文件Set

4、rrr = CreateObject("Scripting.FileSystemObject")Set r = rrr.GetFolder("d：folder1")For Each i In r.FilesWorkbooks.Open Filename：=("d：folder1" + i.Name + "")NextG,刪除文件c.xlskill "d：folder1c.xls"H,刪除文件夾folderSet aaa = CreateObject("Scripting.FileSys

5、temObject")aaa.DeleteFolder "d：folder"2. 8excel vba一次性獲取文件夾下的所有文件名的方法小生今天上網(wǎng)下載了一個財務(wù)常用報表的文件包，里面有幾百個excel工作表，要是手工一個一個的獲得文件名的話，那我可是要忙十天半月哦。于是想到昨論 壇就是vba論壇，昨不充分利用excel 自身的高級應(yīng)用呀，呵呵，實現(xiàn)的代碼如下，把工作量幾天的任務(wù)可是一下子就完成了，這就是excel vba給你工作提高效率的結(jié)果！excle vba自動獲取同一文件夾下所有工作表的名稱紅色代碼：按Alt+F11，打開VBA編輯器，插入一個模塊，把下

6、面的代碼貼進(jìn)去，按F5執(zhí)行Sub t()Dim s As FileSearch '定義一個文件搜索對象Set s = Application.FileSearchs.LookIn = "c：" '注意路徑，換成你實際的路徑s.Filename = "*.*" '搜索所有文件s.Execute '執(zhí)行搜索Cells.Delete '表格清空For i = 1 To s.FoundFiles.CountCells(i, 1) = s.FoundFiles(i) '每一行第一列填寫一個文件名NextEnd Sub

7、現(xiàn)在獲得的可是帶路徑的工作表名，去掉前的路徑可用以下方法；=RIGHT(A1,LEN(A1)-FIND("#",SUBSTITUTE(A1,"","#",LEN(A1)-LEN(SUBSTITUTE(A1,"",)最后用常規(guī)的方法往下拖，就完成了筆者所需的工作表名。outlook下VBA編程：把公用文件夾里的郵件附件拷貝出來保存在硬盤上2009-06-17 09：35Sub SaveAttachments()Dim oApp As Outlook.ApplicationDim oNameSpace As NameS

8、paceDim oFolder As MAPIFolderDim oMailItem As ObjectDim sMessage As StringBeforeDate = #10/1/2007# ' choose the end date of wantedMyDir = "E：liuxc-workoil lossbackup from public folder" ' choose the folder location for saveSender = "Hz121 Supervisor" ' caution, case s

9、ensitiveSendFile = "HZ121-1_Daily.xls"MyY = 0Set oApp = New Outlook.ApplicationSet oNameSpace = oApp.GetNamespace("MAPI")Set oFolder = oNameSpace.PickFolderFor Each oMailItem In oFolder.ItemsWith oMailItemMyT3 = Left(CStr(oMailItem.CreationTime), 10)If CDate(oMailItem.CreationTim

10、e) >= BeforeDate ThenIf oMailItem.SenderName = Sender ThenIf oMailItem.Attachments.Count > 0 Then ' protect errorFor i = 1 To oMailItem.Attachments.CountIf oMailItem.Attachments.Item(i).FileName = SendFile ThenMyT1 = InStr(1, oMailItem.Attachments.Item(i).FileName, ".", 1)MyT2 =

11、Left(oMailItem.Attachments.Item(i).FileName, 19) + "-" + MyT3 + ".xls"oMailItem.Attachments.Item(i).SaveAsFile MyDir & MyT2MsgBox oMailItem.Attachments.Item(i).DisplayName & " was saved as " & oMailItem.Attachments.Item(i).FileNameEnd IfNext iEnd IfEnd IfEls

12、eMyY = MyY + 1If MyY > 10 Then GoTo LoopEndEnd IfEnd WithNext oMailItemLoopEnd：' Set oMailItem = Nothing' Set oFolder = Nothing' Set oNameSpace = Nothing' Set oApp = Nothing3. Excel VBA把選定文件夾中的工作簿導(dǎo)入到新建ACCESS數(shù)據(jù)庫中2010-04-24 22：33方法一Sub Create_AccessProject()Dim AccessData As ObjectS

13、et AccessData = CreateObject("Access.Application")Dim Stpath As StringStpath = ThisWorkbook.Path & "DSEM-Stock-Allocation.mdb" '設(shè)定路徑If Dir(Stpath, vbDirectory) = "DSEM-Stock-Allocation.mdb" ThenKill (Stpath)End IfAccessData.NewCurrentDatabase StpathSet AccessDat

14、a = 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 "Da

15、ta Source =" & Stpath & "Jet OLEDB：Database Password=" & ""'strSQL = "Create Table myData(last_date char(8)"'rstAnswers.Open strSQL, cnnaccessSet rstAnswers = NothingSet cnnaccess = NothingMyMainFile = ThisWorkbook.NameDim CurFile As StringAppli

16、cation.DisplayAlerts = FalsemyFile = Application.GetOpenFilename("(*.xls),*.xls)", , "Please Select Files")If myFile = False Then Exit SubDirLoc = CurDir(myFile) & ""CurFile = Dir(DirLoc & "*.xls")Do While CurFile <> vbNullStringSet objAccess = C

17、reateObject("Access.Application")LinkFile = DirLoc & CurFileTableName = Left(CurFile, Len(CurFile) - 4)If CurFile = "HONHAI-VMIData1.xls" ThenWith objAccess.OpenCurrentDatabase (ThisWorkbook.Path & "DSEM-Stock-Allocation.mdb").DoCmd.TransferSpreadsheet acLink, 8

18、, TableName, LinkFile, True, "Aging Report$"End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingCurFile = DirElseWith objAccess.OpenCurrentDatabase (ThisWorkbook.Path & "DSEM-Stock-Allocation.mdb").DoCmd.TransferSpreadsheet acImport, 8, TableName, LinkFile, True, &qu

19、ot;"End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingCurFile = DirEnd IfLoopEnd Sub方法二Sub Folder2Access()Dim db As DAO.DatabaseDim ws As DAO.WorkspaceSet ws = DBEngine.Workspaces(0)Set db = ws.OpenDatabase("C：CustomersDataBaseDSEM-PO-Stock-Status.mdb", False, False, "

20、")db.Execute ("delete * from DSEM-MovingPlan")db.CloseSet db = NothingDim myFile As StringDim s As FileSearch '定義一個文件搜索對象Set s = Application.FileSearchs.LookIn = "C：CustomersDataBaseTest" '注意路徑，換成你實際的路徑s.Filename = "*.*" '搜索所有文件s.Execute '執(zhí)行搜索For i

21、= 1 To s.FoundFiles.CountFullName1 = Right(s.FoundFiles(i), Len(s.FoundFiles(i) - Len("C：CustomersDataBaseTest")Filename = Left(FullName1, Len(FullName1) - 4)Set objAccess = CreateObject("Access.Application")myFile = "C：CustomersDataBaseTest" & Filename & "

22、.xls"With objAccess.OpenCurrentDatabase ("C：CustomersDataBaseDSEM-PO-Stock-Status.mdb").DoCmd.TransferSpreadsheet acImport, 8, "DSEM-MovingPlan", myFile, True, ""End WithobjAccess.CloseCurrentDatabaseSet objAccess = NothingNextEnd Sub4. vba操作文件及文件夾示例2009-08-20 00：0

23、7vba操作文件及文件夾示例利用excel中的vba可以對電腦中的文件及文件夾做一些常用的操作。包括復(fù)制、重命名、刪除等，其中一些簡單的示例總結(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，

24、新建2個文件命名為a.xls和b.xlsWorkbooks.AddActiveWorkbook.SaveAs Filename：="D：foldera.xls"ActiveWorkbook.SaveAs Filename：="D：folderb.xls"3,創(chuàng)建新文件夾folder1并把a.xls復(fù)制到新文件夾重新命名為c.xlsMkDir "D：folder1"FileCopy "D：foldera.xls", "D：folder1c.xls"4,復(fù)制folder中所有文件到folder1Se

25、t qqq = CreateObject("Scripting.FileSystemObject")qqq.CopyFolder "D：folder", "D：folder1"5,重命名a.xls為d.xlsname "d：folder1a.xls" as "d：folder1d.xls"6,判斷文件及文件夾是否存在Set yyy = CreateObject("Scripting.FileSystemObject")If yyy.FolderExists("D：f

26、older1) = True Then .If yyy.FileExists("D：folder1d.xls) = True Then .7,打開folder1中所有文件Set rrr = CreateObject("Scripting.FileSystemObject")Set r = rrr.GetFolder("d：folder1")For Each i In r.FilesWorkbooks.Open Filename：=("d：folder1" + i.Name + "")Next 8,刪除文件

27、c.xlskill "d：folder1c.xls" 9,刪除文件夾folderSet aaa = CreateObject("Scripting.FileSystemObject")aaa.DeleteFolder "d：folder"VBA Dir 函數(shù) 遍歷文件夾下的所有文件2010-05-26 17：305. VBA Dir函數(shù)第 1.12例 Dir函數(shù)一、題目：要求編寫一段代碼，運用Dir函數(shù)返回一個文件夾的文件列表。二、代碼：Sub 示例_1_12()Dim wjmwjm = Dir("C：WINDOWSWIN.

28、ini")MsgBox wjmwjm = Dir("C：WINDOWS*.ini")wjm = DirEnd Sub三、代碼詳解1、Sub 示例_1_12()：宏程序的開始語句。宏名為示例_1_12。2、Dim wjm ：變量wjm聲明為可變型數(shù)據(jù)類型。3、wjm = Dir("C：WINDOWSWIN.ini") ：如果該文件存在則返回“WIN.INI”(在C：Windows 文件夾中) ，把返回的文件名賦給變量wjm 。如果該文件不存在則wjm=”。4、wjm = Dir("C：WINDOWS*.ini") ：返回帶指定

29、擴展名的文件名。如果超過一個 *.ini 文件存在，函數(shù)將返回按條件第一個找到的文件名。5、wjm = Dir ：若第二次調(diào)用 Dir 函數(shù)，但不帶任何參數(shù)，則函數(shù)將返回同一目錄下的下一個 *.ini 文件。Dir函數(shù)返回一個字符串 String，用以表示一個文件名、目錄名或文件夾名稱，它必須與指定的模式或文件屬性、或磁盤卷標(biāo)相匹配。Dir(pathname, attributes)Dir 函數(shù)的語法具有以下幾個部分：pathname 可選參數(shù)。用來指定文件名的字符串表達(dá)式，可能包含目錄或文件夾、以及驅(qū)動器。如果沒有找到 pathname，則會返回零長度字符串 ("")。a

30、ttributes 可選參數(shù)。常數(shù)或數(shù)值表達(dá)式，其總和用來指定文件屬性。如果省略，則會返回匹配 pathname 但不包含屬性的文件。EXCEL的VBA用于同時顯示目錄文件夾和文件列表2010-05-22 18：41”VBA工具中要引用microsoft scipting runtimeDim pt As RangeSub 查找文件夾下子文件夾及其大小()Dim theDir As StringSet pt = ActiveSheet.Range("a1")pt.Worksheet.Columns(1).ClearContents '清除第一列theDir = Ap

31、plication.InputBox ("輸入指定文件夾的路徑：", "查看子文件夾及其大小")pt = theDir 列出選取的目錄名listPath theDir 用于列出子目錄和文件pt.Worksheet.Columns("a：b").AutoFitEnd SubSub listPath(strDir As String)Dim thePath As StringDim strSdir As StringDim theDirs As Scripting.FoldersDim theDir As Scripting.Folder

32、Dim row As IntegerDim s As StringDim myFso As Scripting.FileSystemObjectSet myFso = New Scripting.FileSystemObjectIf Right(strDir, 1) <> "" Then strDir = strDir & ""thePath = thePath & strDirrow = pt.row '此段為獲取此目錄下的文件名s = Dir(thePath, 7) '獲取第一個文件Do While s &

33、lt;> ""row = row + 1Cells(row, 1) = s '文件的名稱Cells(row, 1).Font.Color = RGB(256, 12, 213)Cells(row, 1).Font.Bold = Tures = Dir 下一個文件LoopSet pt = Cells(row, 1)Set pt = pt.Offset(1, 0)Set theDirs = myFso.getfolder(strDir).subfoldersFor Each theDir In theDirspt = theDir.Pathpt.Next = th

34、eDir.SizelistPath theDir.PathNextSet myFso = NothingEnd SubPrivate Sub CommandButton1_Click()查找文件夾下子文件夾及其大小End Sub6. 用VBA獲取文件夾中的文件列表如果我們要在Excel中獲取某個文件夾中所有的文件列表，可以通過下面的VBA代碼來進(jìn)行。代碼運行后，首先彈出一個瀏覽文件夾對話框，然后新建一個工作簿，并在工作表的A至F列分別列出選定文件夾中的所有文件的文件名、文件大小、創(chuàng)建時間、修改時間、訪問時間及完整路徑。方法如下：1.按Alt+F11，打開VBA編輯器，單擊菜單“插入模塊”，將下

35、面的代碼粘貼到右側(cè)的代碼窗口中：Option ExplicitSub GetFileList()Dim strFolder As StringDim varFileList As VariantDim FSO As Object, myFile As ObjectDim myResults As VariantDim l As Long'顯示打開文件夾對話框With Application.FileDialog(msoFileDialogFolderPicker).ShowIf .SelectedItems.Count = 0 Then Exit Sub '未選擇文件夾strF

36、older = .SelectedItems(1)End With'獲取文件夾中的所有文件列表varFileList = fcnGetFileList(strFolder)If Not IsArray(varFileList) ThenMsgBox "未找到文件", vbInformationExit SubEnd If'獲取文件的詳細(xì)信息，并放到數(shù)組中ReDim myResults(0 To UBound(varFileList) + 1, 0 To 5)myResults(0, 0) = "文件名"myResults(0, 1) =

37、"大?。ㄗ止?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)myResult

38、s(l + 1, 0) = CStr(varFileList(l)myResults(l + 1, 1) = myFile.SizemyResults(l + 1, 2) = myFile.DateCreatedmyResults(l + 1, 3) = myFile.DateLastModifiedmyResults(l + 1, 4) = myFile.DateLastAccessedmyResults(l + 1, 5) = myFile.PathNext lfcnDumpToWorksheet myResultsSet myFile = NothingSet FSO = Nothing

39、End SubPrivate Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant' 如果文件夾中包含文件返回一個二維數(shù)組，否則返回FalseDim f As StringDim i As IntegerDim FileList() As StringIf strFilter = "" Then strFilter = "*.*"Select Case Right$(strPath, 1)Case ""

40、, "/"strPath = Left$(strPath, Len(strPath) - 1)End SelectReDim Preserve FileList(0)f = Dir$(strPath & "" & strFilter)Do While Len(f) > 0ReDim Preserve FileList(i) As StringFileList(i) = fi = i + 1f = Dir$()LoopIf FileList(0) <> Empty ThenfcnGetFileList = FileList

41、ElsefcnGetFileList = FalseEnd IfEnd FunctionPrivate Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)Dim iSheetsInNew As IntegerDim sh As Worksheet, wb As WorkbookDim myColumnHeaders() As StringDim l As Long, NoOfRows As LongIf mySh Is Nothing Then'新建一個工作簿iSheetsInNew = Appl

42、ication.SheetsInNewWorkbookApplication.SheetsInNewWorkbook = 1Set wb = Application.Workbooks.AddApplication.SheetsInNewWorkbook = iSheetsInNewSet sh = wb.Sheets(1)ElseSet mySh = shEnd IfWith shRange(.Cells(1, 1), .Cells(UBound(varData, 1) + 1, UBound(varData, 2) + 1) = varData.UsedRange.Columns.Auto

43、FitEnd WithSet sh = NothingSet wb = NothingEnd Sub2.關(guān)閉VBA編輯器，回到Excel工作表中，按Alt+F8，打開“宏”對話框，選擇“GetFileList”，單擊“運行”按鈕。7. VBA中如何取文件的最后修改時間?已經(jīng)解決了，新的代碼-Sub searchfiles()With Application.FileSearch.NewSearch.LookIn = "D：ttt".Filename = "*.xls".SearchSubFolders = True.FileType = msoFileT

44、ypeAllFilesIf .Execute() > 0 ThenFor i = 1 To .FoundFiles.CountWorksheets("sheet3").Cells(i, 2).Value = .FoundFiles(i)Dim fs, f, sSet fs = CreateObject("Scripting.FileSystemObject")Set f = fs.GetFile(.FoundFiles(i)s = "Created： " & f.DateCreatedWorksheets("s

45、heet3").Cells(i, 3).Value = sSet f = NothingSet fs = NothingNext iElseMsgBox "no file found."End IfEnd WithEnd Sub8. VBA代碼調(diào)用瀏覽文件夾對話框的幾種方法2009-05-25 15：241、使用API方法'【類型聲明】Private Type BROWSEINFOhWndOwner As LongpIDLRoot As LongpszDisplayName As LonglpszTitle As LongulFlags As Longlp

46、fnCallback As LonglParam As LongiImage As LongEnd Type'【API聲明】Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ByVal pszPath As String) As LongPrivate Declare Function SHBrowseForFolder Lib "shell32.dll&qu

47、ot; _Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPrivate Declare Function lstrcat Lib "kernel32" _Alias "lstrcatA" (ByVal lpString1 As String, _ByVal lpString2 As String) As LongPrivate Declare Function OleInitialize Lib "ole32.dll" _(lp As

48、Any) As LongPrivate Declare Sub OleUninitialize Lib "ole32" ()Private Const BIF_USENEWUI = &H40Private Const MAX_PATH = 260'【自定義函數(shù)】Public Function GetFolder_API(sTitle As String, Optional vFlags As Variant) As StringDim lpIDList As LongDim sBuffer As StringDim BInfo As BROWSEINFOIf

49、 IsMissing(vFlags) Then vFlags = BIF_USENEWUICall OleInitialize(ByVal 0&)With BInfo.lpszTitle = lstrcat(sTitle, "").ulFlags = vFlagsEnd WithlpIDList = SHBrowseForFolder(BInfo)If (lpIDList) ThensBuffer = Space(MAX_PATH)SHGetPathFromIDList lpIDList, sBuffersBuffer = Left(sBuffer, InStr(s

50、Buffer, vbNullChar) - 1)If sBuffer <> "" Then GetFolder_API = sBufferEnd IfCall OleUninitializeEnd Function'【使用方法】Sub Test()MsgBox GetFolder_API("選擇文件夾")End Sub2、使用Shell.Application方法Sub GetFloder_Shell()Set objShell = CreateObject("Shell.Application")Set objF

51、older = objShell.BrowseForFolder(0, "選擇文件夾", 0, 0)If Not objFolder Is Nothing ThenMsgBox objFolder.self.pathEnd IfSet objFolder = NothingSet objShell = NothingEnd Sub3、使用FileDialog方法Sub GetFloder_FileDialog()Dim fd As FileDialogSet fd = Application.FileDialog(msoFileDialogFolderPicker)If f

52、d.Show = -1 Then MsgBox fd.SelectedItems(1)Set fd = NothingEnd Sub以上方法在WINXP+OFFICE2003中測試通過Excel VBA選擇目標(biāo)文件夾方法2009-04-13 08：499. 用VBA選擇目標(biāo)文件夾幾種實現(xiàn)代碼：1.FileDialog 屬性Sub Sample1()With Application.FileDialog(msoFileDialogFolderPicker)If .Show = True ThenMsgBox .SelectedItems(1)'txtFolder.Text = .Sele

53、ctedItems(1)End IfEnd WithEnd Sub2.shell 方法Sub Sample2()Dim Shell, myPathSet Shell = CreateObject("Shell.Application")Set myPath = Shell.BrowseForFolder(&O0, "請選擇文件夾", &H1 + &H10, "G：")If Not myPath Is Nothing Then MsgBox myPath.Items.Item.PathSet Shell = No

54、thingSet myPath = NothingEnd Sub3.API 方法Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _(ByVal pidl As Long, ByVal pszPath As String) As LongDeclare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _(

55、lpBrowseInfo As BROWSEINFO) As LongDeclare Function GetDesktopWindow Lib "user32" () As LongPublic Type BROWSEINFOhOwner As LongpidlRoot As LongpszDisplayName As StringlpszTitle As StringulFlags As Longlpfn As LonglParam As LongiImage As LongEnd TypeSub Sample3()Dim buf As Stringbuf = GetF

56、older("請選擇文件夾")If buf = "" Then Exit SubMsgBox bufEnd SubFunction GetFolder(Optional Msg) As StringDim bInfo As BROWSEINFO, pPath As StringDim R As Long, X As Long, pos As IntegerbInfo.pidlRoot = 0&bInfo.lpszTitle = MsgbInfo.ulFlags = &H1X = SHBrowseForFolder(bInfo)pPath

57、= Space$(512)R = SHGetPathFromIDList(ByVal X, ByVal pPath)If R Thenpos = InStr(pPath, Chr$(0)GetFolder = Left(pPath, pos - 1)ElseGetFolder = ""End IfEnd Function10. VBA代碼調(diào)用瀏覽文件夾對話框的幾種方法1、使用API方法'【類型聲明】Private Type BROWSEINFOhWndOwner As LongpIDLRoot As LongpszDisplayName As LonglpszTit

58、le As LongulFlags As LonglpfnCallback As LonglParam As LongiImage As LongEnd Type'【API聲明】Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ByVal pszPath As String) As LongPrivate Declare Function SHBrowseForFold

59、er Lib "shell32.dll" _Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPrivate Declare Function lstrcat Lib "kernel32" _Alias "lstrcatA" (ByVal lpString1 As String, _ByVal lpString2 As String) As LongPrivate Declare Function OleInitialize Lib &qu

60、ot;ole32.dll" _(lp As Any) As LongPrivate Declare Sub OleUninitialize Lib "ole32" ()Private Const BIF_USENEWUI = &H40Private Const MAX_PATH = 260'【自定義函數(shù)】Public Function GetFolder_API(sTitle As String, Optional vFlags As Variant) As StringDim lpIDList As LongDim sBuffer As Stri

61、ngDim BInfo As BROWSEINFOIf IsMissing(vFlags) Then vFlags = BIF_USENEWUICall OleInitialize(ByVal 0&)With BInfo.lpszTitle = lstrcat(sTitle, "").ulFlags = vFlagsEnd WithlpIDList = SHBrowseForFolder(BInfo)If (lpIDList) ThensBuffer = Space(MAX_PATH)SHGetPathFromIDList lpIDList, sBuffersBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)If sBuffer <> "" Then GetFolder_API = sBufferEnd IfCall OleUninitializeEnd Function'【使用方