haquocquan > 13-11-10, 12:18 AM
Function FolderCheck(sPath As String) As Boolean
If Right(sPath, 1) = "\" Then
sPath = Left(sPath, Len(sPath) - 1)
End If
Dim filesys
Set filesys = CreateObject("Scripting.FileSystemObject")
FolderCheck = filesys.FolderExists(sPath)
End FunctionMkDir sPathRmDir sPathhaquocquan > 17-11-10, 12:34 AM
Sub ListFiles(strPath As String, Optional strFileSpec As String, Optional bIncludeSubfolders As Boolean)
On Error GoTo Err_Handler
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
Dim rsfile As Recordset
Set rsfile = CurrentDb.OpenRecordset("tblList", dbOpenDynaset)
For Each varItem In colDirList
rsfile.AddNew
rsfile!filename = varItem
rsfile.Update
'lst.AddItem varItem
Next
'End If
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End SubSub FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End SubPublic Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End FunctionSub XoaTatCa()
Dim FSO As Object
Dim MyPath As String
Set FSO = CreateObject("scripting.filesystemobject")
MyPath = spath '<< thay doi duong dan nhe
If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If
If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " khong ton tai"
Exit Sub
End If
On Error Resume Next
FSO.deletefile MyPath & "\*.*", True
FSO.deletefolder MyPath & "\*.*", True
MsgBox "Da xoa xong !"
On Error GoTo 0
End SubDoquangLam > 17-11-10, 10:32 PM
DoquangLam > 17-11-10, 11:32 PM
Noname > 17-11-10, 11:41 PM
DoquangLam > 17-11-10, 11:55 PM
DoquangLam > 18-11-10, 05:25 PM
haquocquan > 18-11-10, 05:41 PM
Private Sub Form_Open(Cancel As Integer)
On error resume next
CurrentDb.Execute "delete * from tblFileDataList"
Call ListFiles(Application.CurrentProject.Path, "*.*", True)
End Subhaquocquan > 17-02-11, 12:14 AM
Sub ListFolder()
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FSOfolder As Object
Dim subfolder As Object
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("LuuSub", dbOpenDynaset)
Set FSOfolder = FSO.GetFolder("E:\XUAT\")
For Each subfolder In FSOfolder.SubFolders
rs.AddNew
rs!abc = subfolder.Name
rs.Update
Next subfolder
Set FSOfolder = Nothing
End Sub