VB6 Code Bank: File, Folders & Text File Handling, Date & Time
Alen1.1- Super Administrator
Jumlah posting : 82
Age : 33
Fakultas : Fasilkom
Jurusan : sistem informasi
Interest in : Visual Basic,xna,C#
Registration date : 07.01.09
by Alen1.1 Sat Jan 17, 2009 1:56 am
File/Folders Handling 1
- Create Nested Directories (in two ways)
- Code:
'Using API:
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" _
(ByVal lpPath As String) As Long
Sub CreateDirectories()
'This will create the directory "c:\this\is\a\test\directory\", if it doesn't exist already
MakeSureDirectoryPathExists "c:\this\is\a\test\directory\"
End Sub
'Without Using API:
Public Function fnCreateDirectories(strPath As String)
'This function is used to create recursive directories
'This function will check for folder exist if doesn't exist then it will create it.
'For example: if strFolderPath = "C:\Temp\Testing\Temp\Testing\Temp\Testing" then
'It will check existance of the folders: C:, C:\Temp, C:\Temp\Testing, etc.
'If folders doesn't exist then it will create those folders.
'You can call this function as:
'Call CreateDirectories ("C:\Temp\Testing\Temp\Testing\Temp\Testing")
'This will create all directories and its subdirectories.
Dim arrPath() As String
Dim strTemp As String
Dim i As Integer
'strPath = "C:\Temp\Testing\Testing"
On Error GoTo fnCreateDirectories_Error
arrPath = Split(strPath, "\")
For i = 0 To UBound(arrPath)
'create folder paths
If strTemp <> "" Then
strTemp = strTemp & "\" & arrPath(i)
Else
strTemp = arrPath(i)
End If
'if folder doesn't exists then create it
If Not fnFolderExists(strTemp) Then
On Error Resume Next
MkDir strTemp
End If
Next i
On Error GoTo 0
Exit Function
fnCreateDirectories_Error:
Call MsgBox(Err.Number & " " & Err.Description, vbExclamation, App.Title)
End Function
Public Function fnFolderExists(strFolder As String) As Boolean
'Check if folder exists
fnFolderExists = (Dir$(strFolder, vbDirectory) <> vbNullString)
End Function
- How to Copy Folder from one directory to another directory (in Two ways)
- Code:
'Using FSO:
Public Sub CopyFolderUsingFSO(ByVal sSourceFolder As String, ByVal sDestinationFolder As String, _
Optional ByVal bOverWrite As Boolean = True)
'Set a reference to "Microsoft Scripting Runtime"
' All file operations should be protected against errors.
' None of these functions works on open files.
On Error Resume Next
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
FSO.CopyFolder sSourceFolder, sDestinationFolder, bOverWrite
Set FSO = Nothing
End Sub
'Using XCopy:
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Public Sub CopyFolderUsingXcopy(ByVal sSourceFolder As String, ByVal sDestinationFolder As String, _
Optional ByVal bOverWrite As Boolean = True, Optional ByVal bFailIfError = False)
Dim sCommand As String
Call MakeSureDirectoryPathExists(sDestinationFolder)
sCommand = "Cmd.exe /C xcopy " & ChrW$(34) & sSourceFolder & ChrW$(34) & " " & ChrW$(34) & _
sDestinationFolder & ChrW$(34) & " /E /Q"
If bOverWrite Then sCommand = sCommand & " /Y"
If Not bFailIfError Then sCommand = sCommand & " /C"
Shell sCommand
End Sub
- File Copy API with Progress Dialog
- Code:
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const FO_COPY = &H2
Public Function ShellFileCopy(src As String, dest As String, _
Optional NoConfirm As Boolean = False) As Boolean
'PARAMETERS: src: Source File (FullPath)
' dest: Destination File (FullPath)
' NoConfirm (Optional): If set to true, no confirmation box is displayed when
' overwriting existing files, and no copy progress dialog box is displayed
'Returns: True if Successful; False otherwise;
Dim WinType_SFO As SHFILEOPSTRUCT
Dim lRet As Long
Dim lflags As Long
lflags = FOF_ALLOWUNDO
If NoConfirm Then lflags = lflags & FOF_NOCONFIRMATION
With WinType_SFO
.wFunc = FO_COPY
.pFrom = src
.pTo = dest
.fFlags = lflags
End With
lRet = SHFileOperation(WinType_SFO)
ShellFileCopy = (lRet = 0)
End Function
'How can I call this function:
'Dim bSuccess as boolean
'bSuccess = ShellFileCopy ("C:\MyFile.txt", "D:\MyFile.txt")
- Get Oldest File From Directory
- Code:
Public Function GetOldestFileFromDir(ByVal filePathAndPattern As String, _
Optional ByVal attributes As VbFileAttribute = vbNormal) As String
'This function is used to get the oldest file from the given directory.
Dim strFile As String
Dim strOldest As String
Dim strPath As String
strPath = Left(filePathAndPattern, InStrRev(filePathAndPattern, "\"))
strFile = Dir(filePathAndPattern, attributes)
Do While Len(strFile) > 0
If Len(strOldest) = 0 Then
strOldest = strFile
ElseIf FileDateTime(strPath & strFile) < FileDateTime(strPath & strOldest) Then
strOldest = strFile
End If
strFile = Dir
Loop
GetOldestFileFromDir = strOldest
End Function
'How can I Call this function:
'Debug.Print GetOldestFileFromDir("C:\Temp\*.txt")
- How to return a string containing all possible information about the file
- Code:
Public Function FileInfo(FileName) As String
Dim File As String
Dim Temp As String
Dim Attrib As Integer
File = FileName
' Use GetAttr function to get all attributes info
Attrib = GetAttr(File)
Temp = File & vbCrLf & vbCrLf
Temp = Temp & "Date/Time: " & FileDateTime(File) & vbCrLf
Temp = Temp & "Size: " & FileLen(File) & " bytes" & vbCrLf
'Test for read only attribute by masking bits
If (Attrib And vbReadOnly) = vbReadOnly Then
Temp = Temp & "ReadOnly: X" & vbCrLf
End If
' Test for hidden attribute
If (Attrib And vbHidden) = vbHidden Then
Temp = Temp & "Hidden: X" & vbCrLf
End If
' Test for system attribute
If (Attrib And vbSystem) = vbSystem Then
Temp = Temp & "System: X" & vbCrLf
End If
' Test for archive attribute
If (Attrib And vbArchive) = vbArchive Then
Temp = Temp & "Archive: X" & vbCrLf
End If
' Return Temp string containing all file info
FileInfo = Temp
End Function
- How to delete the given directory and all the files it contains
- Code:
Public Function fnDeleteDirectory(ByVal Dir_Name As String)
On Error Resume Next
Dim file_name As String
Dim files As Collection
Dim i As Integer
' Get a list of files it contains.
Set files = New Collection
file_name = Dir$(Dir_Name & "\*.*", vbReadOnly + _
vbHidden + vbSystem + vbDirectory)
Do While Len(file_name) > 0
If (file_name <> "..") And (file_name <> ".") Then
files.Add Dir_Name & "\" & file_name
End If
file_name = Dir$()
Loop
'Delete the files.
For i = 1 To files.Count
file_name = files(i)
'See if it is a directory.
If GetAttr(file_name) And vbDirectory Then
'It is a directory. Delete it.
fnDeleteDirectory file_name
Else
'It's a file. Delete it.
SetAttr file_name, vbNormal
Kill file_name
End If
Next i
'The directory is now empty. Delete it.
RmDir Dir_Name
End Function
- How to check whether the given folder exists or not (in four ways)
- Code:
'Using Dir:
Public Function FolderExistsUsingDir(ByVal strFolder As String) As Boolean
On Error Resume Next
FolderExistsUsingDir = (Dir$(strFolder, vbDirectory) <> vbNullString)
End Function
'How can I call this function:
'Debug.Print FolderExistsUsingDir("C:\Temp\b1")
'Using FSO:
Public Function FolderExistsUsingFSO(ByVal sFolder As String) As Boolean
'Set a reference to "Microsoft Scripting Runtime"
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
FolderExistsUsingFSO = FSO.FolderExists(sFolder)
Set FSO = Nothing
End Function
'How can I call this function:
'Debug.Print FolderExistsUsingFSO("C:\Temp\b1")
'Using Attribute:
Public Function FolderExistsUsingAttrib(ByVal sFolder As String) As Boolean
Dim lRetVal As Long
On Error GoTo FileDoesntExist:
lRetVal = GetAttr(sFolder)
FolderExistsUsingAttrib = True
Exit Function
FileDoesntExist:
FolderExistsUsingAttrib = False
End Function
'How can I call this function:
'Debug.Print FolderExistsUsingAttrib("C:\Temp\b1")
'Using API:
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" _
(ByVal pszPath As String) As Long
Public Function FolderExistsUsingAPI(ByVal sFolder As String) As Boolean
FolderExistsUsingAPI = PathIsDirectory(sFolder)
End Function
'How can I call this function:
'Debug.Print FolderExistsUsingAPI("C:\Temp\b1")
- How to delete the given file (in four ways)
- Code:
'Using Kill:
Sub DeleteFileUsingKill()
' All file operations should be protected against errors.
' None of these functions works on open files.
On Error Resume Next
' Delete one or more files--Kill also supports wildcards.
Kill "d:\temporary.*"
End Sub
'Using API:
Private Declare Function DeleteFile Lib "kernel32.dll" Alias "DeleteFileA" _
(ByVal lpFileName As String) As Long
Sub DeleteFileUsingAPI()
Dim intResult As Long ' return value
intResult = DeleteFile("C:\Temp.txt") 'Doesn't go to Recycle Bin!
If intResult = 1 Then
MsgBox "File deleted."
Else
MsgBox "Encountered Error. Couldn't Delete!"
End If
End
End Sub
'Using FSO:
Public Sub FileDeleteUsingFSO(ByVal sFileName As String)
'Set a reference to "Microsoft Scripting Runtime"
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
Call FSO.DeleteFile(sFileName, True)
Set FSO = Nothing
End Sub
'Move to Recycle Bin:
http://codeitbetter.co.nr/vb6/code/Vb6Code00106.html
'Using Dos Command Del:
Public Sub FileDeleteUsingDel(ByVal sFileName As String)
Dim sCommand As String
sCommand = "Cmd.exe /C Del /Q /F " & ChrW$(34) & sFileName & ChrW$(34)
Shell sCommand
End Sub
- How to check whether the given file is locked
- Code:
Public Function fnFileLocked(ByVal strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
fnFileLocked = True
End If
End Function
- How to use Dir$ function to get filenames and display in a list box or something
- Code:
strFilename = Dir$(strPath & "*.*", 63)
strfullpath = strPath & strFilename
Do Until Len(strFilename) = 0
If Not (strFilename = "." Or strFilename = "..") Then
'Add to list (you decide) with full path recorded somewhere and filename
'displayed
lst.Add strfullpath, strFilename
End If
'blank file name as otherwise it won't be set to zero length and you'd
'endlessly loop
strFilename = ""
strFilename = Dir$
Loop
Alen1.1- Super Administrator
- Jumlah posting : 82
Age : 33
Fakultas : Fasilkom
Jurusan : sistem informasi
Interest in : Visual Basic,xna,C#
Registration date : 07.01.09
by Alen1.1 Sat Jan 17, 2009 1:59 am
File/Folders Handling 2
- How to Close a File for a given File Number
- Code:
Option Explicit
Public Function CloseFile(ByVal FileNumber As Long) As Boolean
On Error GoTo CloseFile_Error
Close #FileNumber
CloseFile = True
ExitHere:
On Error GoTo 0
Exit Function
CloseFile_Error:
CloseFile = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CloseFile of Form Form1"
End Function
- How to Read a file and add each line to an array of strings
- Code:
Option Explicit
Public Function ReadArrayFromFile(FilePath As String) As String()
Dim strArray() As String
Dim itemCount As Long, fileNum As Long
On Error GoTo ReadArrayFromFile_Error
itemCount = -1
fileNum = OpenFile(FilePath)
If fileNum = -2 Then
Exit Function
End If
Do While Not EOF(fileNum)
itemCount = itemCount + 1
ReDim Preserve strArray(itemCount)
Input #fileNum, strArray(itemCount)
Loop
Call CloseFile(fileNum)
ReadArrayFromFile = strArray
ExitHere:
On Error GoTo 0
Exit Function
ReadArrayFromFile_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ReadArrayFromFile of Form Form1"
End Function
Public Function OpenFile(ByVal FilePath As String) As Long
On Error GoTo OpenFile_Error
If Len(Dir$(FilePath)) = 0 Then
OpenFile = -1
Exit Function
End If
OpenFile = FreeFile
Open FilePath For Input As #OpenFile
ExitHere:
On Error GoTo 0
Exit Function
OpenFile_Error:
OpenFile = -2
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure OpenFile of Form Form1"
End Function
Public Function CloseFile(ByVal FileNumber As Long) As Boolean
On Error GoTo CloseFile_Error
Close #FileNumber
CloseFile = True
ExitHere:
On Error GoTo 0
Exit Function
CloseFile_Error:
CloseFile = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CloseFile of Form Form1"
End Function
- How to write a string array to a text file
- Code:
Option Explicit
Public Function WriteArrayToFile(ByRef strArray() As String, ByVal FilePath As String) As Boolean
Dim fileNum As Long
Dim I As Integer
On Error GoTo WriteArrayToFile_Error
fileNum = CreateFile(FilePath)
For I = LBound(strArray) To UBound(strArray)
Print #fileNum, strArray(I)
Next I
Call CloseFile(fileNum)
WriteArrayToFile = True
ExitHere:
On Error GoTo 0
Exit Function
WriteArrayToFile_Error:
WriteArrayToFile = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure WriteArrayToFile of Form Form1"
End Function
Public Function OpenFile(ByVal FilePath As String) As Long
On Error GoTo OpenFile_Error
If Len(Dir$(FilePath)) = 0 Then
OpenFile = -1
Exit Function
End If
OpenFile = FreeFile
Open FilePath For Input As #OpenFile
ExitHere:
On Error GoTo 0
Exit Function
OpenFile_Error:
OpenFile = -2
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure OpenFile of Form Form1"
End Function
Public Function CloseFile(ByVal FileNumber As Long) As Boolean
On Error GoTo CloseFile_Error
Close #FileNumber
CloseFile = True
ExitHere:
On Error GoTo 0
Exit Function
CloseFile_Error:
CloseFile = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CloseFile of Form Form1"
End Function
- How to sort the files using its create date and time?
- Code:
Option Explicit
'This module is used to sort the files using its create date and time.
'The functions will sort the files and store it in an array.
'Developed by Sriraman CS.
Private Type FileTime
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FileTime, _
lpLastAccessTime As FileTime, lpLastWriteTime As FileTime) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FileTime, _
lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FileTime, _
lpLocalFileTime As FileTime) As Long
Dim strFileArray() As String
Sub Test()
Dim icount As Integer
Dim ss As String
'Specify the file path
'specify the optional file extension = "*.JPG"
Call fnLoadArrFiles("D:\Temp\40290_Nema", "*.JPG")
For icount = 1 To UBound(strFileArray)
ss = ss & strFileArray(icount) & vbCrLf
Next icount
MsgBox ss
End Sub
Function fnLoadArrFiles(strFilePath As String, Optional strFileExt As String = "*.JPG") As String
If Not Right(strFilePath, 1) = "\" Then strFilePath = strFilePath & "\"
'retrieve the files from the given path and store it in an array.
strFileArray() = GetFiles(strFilePath & strFileExt, strFilePath, vbNormal + vbHidden + vbSystem)
'Sort the files by create date & time
Call SortArrayDateTime(strFileArray)
End Function
Function GetFiles(filespec As String, filePath As String, Optional Attributes As VbFileAttribute) As String()
Dim result() As String
Dim filename As String, count As Long, path2 As String
Const ALLOC_CHUNK = 50
ReDim result(0 To ALLOC_CHUNK) As String
filename = Dir$(filespec, Attributes)
Do While Len(filename)
count = count + 1
If count > UBound(result) Then
'Resize the result array if necessary.
ReDim Preserve result(0 To count + ALLOC_CHUNK) As String
End If
result(count) = filePath & filename
'Get ready for the next iteration.
filename = Dir$
Loop
' Trim the result array.
ReDim Preserve result(0 To count) As String
GetFiles = result
End Function
Function SortArrayDateTime(strArray)
Dim icount As Integer
Dim intCount As Integer
Dim strNew As String
Dim intNew As Integer
For intCount = LBound(strArray) To UBound(strArray)
strNew = strArray(intCount)
intNew = intCount
For icount = intCount + 1 To UBound(strArray)
'if first is greater than orig then swap
'If DateDiff("s", FileDateTime(strArray(iCount)), FileDateTime(strNew)) < 0 Then
If CheckFileTime(CStr(strArray(icount)), strNew) = strArray(icount) Then
strNew = strArray(icount)
intNew = icount
End If
Next icount
strArray(intNew) = strArray(intCount)
strArray(intCount) = strNew
Next intCount
End Function
Function CheckFileTime(strFile1 As String, strFile2 As String)
'This function checks the file date and time of the given two files and returns the old file.
Dim strTime1 As String
Dim strTime2 As String
Dim intMillSec1 As Integer
Dim intMillSec2 As Integer
Dim intPos As Integer
strTime1 = Trim(Replace(FileDateTime(strFile1), " ", " "))
intPos = InStrRev(strTime1, "~")
intMillSec1 = Val(Mid$(strTime1, intPos + 1, 3))
strTime1 = Left(strTime1, intPos - 1)
strTime2 = Trim(Replace(FileDateTime(strFile2), " ", " "))
intPos = InStrRev(strTime2, "~")
intMillSec2 = Val(Mid$(strTime2, intPos + 1, 3))
strTime2 = Left(strTime2, intPos - 1)
Select Case DateDiff("s", CDate(strTime1), CDate(strTime2))
Case Is > 0
CheckFileTime = strFile1
Case Is = 0
If intMillSec2 >= intMillSec1 Then
CheckFileTime = strFile1
Else
CheckFileTime = strFile2
End If
Case Else
CheckFileTime = strFile2
End Select
End Function
Function FileDateTime(strFileName As String)
'This function returns create date and time of the given file.
Dim lngHandle As Long, SHDirOp As SHFILEOPSTRUCT, lngLong As Long
Dim Ft1 As FileTime, Ft2 As FileTime, SysTime As SYSTEMTIME
'Open the file
lngHandle = CreateFile(strFileName, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, _
OPEN_EXISTING, 0, 0)
'Get the fil's time
GetFileTime lngHandle, Ft1, Ft1, Ft2
'Convert the file time to the local file time
FileTimeToLocalFileTime Ft2, Ft1
'Convert the file time to system file time
FileTimeToSystemTime Ft1, SysTime
FileDateTime = Str$(SysTime.wMonth) + "/" + LTrim(Str$(SysTime.wDay)) + "/" + LTrim(Str$(SysTime.wYear)) _
+ " " + Str$(SysTime.wHour) + ":" + LTrim(Str$(SysTime.wMinute)) + ":" + LTrim(Str$(SysTime.wSecond)) _
+ "~" + LTrim(Str$(SysTime.wMilliseconds))
'Close the file
CloseHandle lngHandle
End Function
- How to Show Open with dialog
- Code:
Public Sub DisplayOpenWith(strFile As String)
'This code displays the Open With Dialog (the one that pops up when you
'double-click a file that does not have an associated application).
On Error Resume Next
Shell "rundll32.exe shell32.dll, OpenAs_RunDLL " & strFile
End Sub
Private Sub Command1_Click()
'Pass the File Name
Call DisplayOpenWith("C:\FileWithNoDefaultApplication.bvq")
End Sub
- How to delete a file by moving it to the recycle bin
- Code:
Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Public Const FO_DELETE As Long = &H3
Public Const FOF_NOCONFIRMATION As Long = &H10
Public Const FOF_ALLOWUNDO As Long = &H40
Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
'Returns True if successful
Public Function Erase2RecycleBin(fileSpec$) As Boolean
Dim SHFileOp As SHFILEOPSTRUCT
With SHFileOp
.wFunc = FO_DELETE
.pFrom = fileSpec$ & vbNullChar
.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With
Erase2RecycleBin = (SHFileOperation(SHFileOp) = 0)
End Function
'Call the function like this:
'blnSuccess = Erase2RecycleBin("C:\Myfolder\myfile")
- How to check the given file is read only
- Code:
Private Declare Function GetFileAttributes Lib "kernel32.dll" Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
Const READONLY = &H1
Private Function CheckIfReadOnly(ByVal FilePathAndName As String) As Boolean
attr = GetFileAttributes(FilePathAndName)
If (attr And &H1) = &H1 Then
CheckIfReadOnly = True
Else
CheckIfReadOnly = False
End If
End Function
- How to check whether given Drive exists
- Code:
Public Function DriveExistsUsingFSO(Optional ByVal sDriveName As String = "C") As Boolean
'Set a reference to "Microsoft scripting Runtime"
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
DriveExistsUsingFSO = FSO.DriveExists(sDriveName)
Set FSO = Nothing
End Function
'How can I call this function:
'Debug.Print DriveExistsUsingFSO("D")
- How to Determine file size in bytes
- Code:
Public Function fnDetermineFileSizeInBytes(strFileName As String) As Long
Dim intReadChan As Integer
intReadChan = FreeFile
Open strFileName For Input As intReadChan 'Can now refer to input file by this
fnDetermineFileSizeInBytes = LOF(intReadChan) 'Gives us our filesize
Debug.Print fnDetermineFileSizeInBytes & " Bytes"
'How can I call this function
'MsgBox fnDetermineFileSizeInBytes("C:\Temp\Project1.exe")
End Function
- How to Rename files (in five ways)
- Code:
'Using Name Statement:
Public Sub RenameFileUsingName(ByVal sOldFileName As String, ByVal sNewFileName As String)
'Using Name on an open file produces an error. You must close an open
'file before renaming it. Name arguments cannot include multiple-character (*)
'and single-character (?) wildcards.
'If the file sNewFileName already exists then it will produce an error
Name sOldFileName As sNewFileName
End Sub
'Using File Copy:
Public Sub RenameFileUsingFileCopy(ByVal sOldFileName As String, ByVal sNewFileName As String)
'Using Name on an open file produces an error. You must close an open
'file before renaming it. Name arguments cannot include multiple-character (*)
'and single-character (?) wildcards.
'If the file sNewFileName already exists then it will overwrite
FileCopy sOldFileName, sNewFileName
End Sub
'Using FSO (Method 1):
Public Sub RenameFileUsingFSO(ByVal sOldFileName As String, ByVal sNewFileName As String)
'Set a reference to "Microsoft scripting Runtime"
'If the file sNewFileName already exists then it will overwrite
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
FSO.CopyFile sOldFileName, sNewFileName
Set FSO = Nothing
End Sub
'Using FSO (Method 2):
Public Sub RenameFileUsingFSO(ByVal sOldFileName As String, ByVal sNewFileName As String)
'Set a reference to "Microsoft scripting Runtime"
'If the Folder sNewFolderName already exists then it will overwrite
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
FSO.GetFile(sOldFileName).Name = Mid$(sNewFileName, InStrRev(sNewFileName, "\") + 1)
Set FSO = Nothing
End Sub
'Using API:
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Public Sub RenameFileUsingAPI(ByVal sOldFileName As String, ByVal sNewFileName As String)
Call CopyFile(sOldFileName, sNewFileName, False)
End Sub
Alen1.1- Super Administrator
- Jumlah posting : 82
Age : 33
Fakultas : Fasilkom
Jurusan : sistem informasi
Interest in : Visual Basic,xna,C#
Registration date : 07.01.09
by Alen1.1 Sat Jan 17, 2009 2:12 am
File/Folders Handling 3
- How to show Browse for folder
- Code:
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
'Set a reference to "Microsoft shell controls and automation"
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
BrowseFolder = F.Items.item.Path
End If
End Function
Private Sub Command1_Click()
'How to call this function
Dim FName As String
FName = BrowseFolder("Select a folder to Insert Pictures", "My Computer")
End Sub
- How to Rename folder (in three ways)
- Code:
'Using Name Statement:
Public Sub RenameFolderUsingName(ByVal sOldFolderName As String, ByVal sNewFolderName As String)
'Using Name on an open file produces an error. You must close an open
'file before renaming it. Name arguments cannot include multiple-character (*)
'and single-character (?) wildcards.
'If the Folder sNewFolderName already exists then it will produce an error
Name sOldFolderName As sNewFolderName
End Sub
'Using FSO Method 1:
Public Sub RenameFolderUsingFSO(ByVal sOldFolderName As String, ByVal sNewFolderName As String)
'Set a reference to "Microsoft scripting Runtime"
'If the Folder sNewFolderName already exists then it will overwrite
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
FSO.CopyFolder sOldFolderName, sNewFolderName
'It will produce error if any files from this folder is opened/locked
FSO.DeleteFolder sOldFolderName, True
Set FSO = Nothing
End Sub
'Using FSO Method 2:
Public Sub RenameFolderUsingFSO(ByVal sOldFolderName As String, ByVal sNewFolderName As String)
'Set a reference to "Microsoft scripting Runtime"
'If the Folder sNewFolderName already exists then it will overwrite
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
sNewFolderName = RemoveBackslash(sNewFolderName)
FSO.GetFolder(sOldFolderName).Name = Mid$(sNewFolderName, InStrRev(sNewFolderName, "\") + 1)
Set FSO = Nothing
End Sub
Public Function RemoveBackslash(ByVal sFolder As String)
If Right$(sFolder, 1) = "\" Then
RemoveBackslash = Left$(sFolder, Len(sFolder) - 1)
End If
End Function
- How to find the Date and time of the file
- Code:
Debug.Print FileDateTime("d:\VS98\Temporary.Dat") ' Returns a Date value
- How to find the name of the current directory
- Code:
'use the CurDir$ function. When this function is passed a drive letter,
'it returns the current directory on that particular path.
'Always use On Error--the current dir might be on a removed floppy disk.
On Error Resume Next
Print CurDir$ ' Displays "D:\VisStudio\VB98"
' The current directory on drive C:
Print = CurDir$("c") ' Displays "C:\WinNT\System"
- How to retrieve all files from a given directory?
- Code:
'An array of filenames in a given directory and also demonstrates the correct way to
'set up the loop:
Function GetFiles(filespec As String, Optional Attributes As VbFileAttribute) As String()
Dim result() As String
Dim filename As String, count As Long, path2 As String
Const ALLOC_CHUNK = 50
ReDim result(0 To ALLOC_CHUNK) As String
filename = Dir$(filespec, Attributes)
Do While Len(filename)
count = count + 1
If count > UBound(result) Then
' Resize the result array if necessary.
ReDim Preserve result(0 To count + ALLOC_CHUNK) As String
End If
result(count) = filename
' Get ready for the next iteration.
filename = Dir$
Loop
' Trim the result array.
ReDim Preserve result(0 To count) As String
GetFiles = result
End Function
- How to list all sub directories names from the given directory
- Code:
Function GetDirectories(path As String, Optional Attributes As VbFileAttribute, _
Optional IncludePath As Boolean) As String()
Dim result() As String
Dim dirname As String, count As Long, path2 As String
Const ALLOC_CHUNK = 50
ReDim result(ALLOC_CHUNK) As String
' Build the path name + backslash.
path2 = path
If Right$(path2, 1) <> "\" Then path2 = path2 & "\"
dirname = Dir$(path2 & "*.*", vbDirectory Or Attributes)
Do While Len(dirname)
If dirname = "." Or dirname = ".." Then
' Exclude the "." and ".." entries.
ElseIf (GetAttr(path2 & dirname) And vbDirectory) = 0 Then
' This is a regular file.
Else
' This is a directory.
count = count + 1
If count > UBound(result) Then
' Resize the result array if necessary.
ReDim Preserve result(count + ALLOC_CHUNK) As String
End If
' Include the path if requested.
If IncludePath Then dirname = path2 & dirname
result(count) = dirname
End If
dirname = Dir$
Loop
' Trim the result array.
ReDim Preserve result(count) As String
GetDirectories = result
End Function
Private Sub Command1_Click()
Dim a() As String
a = GetDirectories("C:\Temp")
For i = LBound(a) To UBound(a)
Debug.Print a(i)
Next i
End Sub
- How to Load the names of all executable files in a directory tree into a ListBox
- Code:
'Note: this is a recursive routine.
Sub ListExecutableFiles(ByVal path As String, lst As ListBox)
Dim names() As String, i As Long, j As Integer
' Ensure that there is a trailing backslash.
If Right(path, 1) <> "\" Then path = path & "\"
' Get the list of executable files.
For j = 1 To 3
' At each iteration search for a different extension.
names() = GetFiles(path & "*." & Choose(j, "exe", "bat", "com"))
' Load partial results in the ListBox lst.
For i = 1 To UBound(names)
lst.AddItem path & names(i)
Next
Next
' Get the list of subdirectories, including hidden ones,
' and call this routine recursively on all of them.
names() = GetDirectories(path, vbHidden)
For i = 1 To UBound(names)
ListExecutableFiles path & names(i), lst
Next
End Sub
Public Function GetFiles(filespec As String, Optional Attributes As VbFileAttribute) As String()
Dim result() As String
Dim filename As String, count As Long, path2 As String
Const ALLOC_CHUNK = 50
ReDim result(0 To ALLOC_CHUNK) As String
filename = Dir$(filespec, Attributes)
Do While Len(filename)
count = count + 1
If count > UBound(result) Then
' Resize the result array if necessary.
ReDim Preserve result(0 To count + ALLOC_CHUNK) As String
End If
result(count) = filename
' Get ready for the next iteration.
filename = Dir$
Loop
' Trim the result array.
ReDim Preserve result(0 To count) As String
GetFiles = result
End Function
Function GetDirectories(path As String, Optional Attributes As VbFileAttribute, _
Optional IncludePath As Boolean) As String()
Dim result() As String
Dim dirname As String, count As Long, path2 As String
Const ALLOC_CHUNK = 50
ReDim result(ALLOC_CHUNK) As String
' Build the path name + backslash.
path2 = path
If Right$(path2, 1) <> "\" Then path2 = path2 & "\"
dirname = Dir$(path2 & "*.*", vbDirectory Or Attributes)
Do While Len(dirname)
If dirname = "." Or dirname = ".." Then
' Exclude the "." and ".." entries.
ElseIf (GetAttr(path2 & dirname) And vbDirectory) = 0 Then
' This is a regular file.
Else
' This is a directory.
count = count + 1
If count > UBound(result) Then
' Resize the result array if necessary.
ReDim Preserve result(count + ALLOC_CHUNK) As String
End If
' Include the path if requested.
If IncludePath Then dirname = path2 & dirname
result(count) = dirname
End If
dirname = Dir$
Loop
' Trim the result array.
ReDim Preserve result(count) As String
GetDirectories = result
End Function
- How to Retrieve the Filepath from a Path
- Code:
Option Explicit
Public Function GetFilePath(ByVal FilePath As String) As String
Dim slashLocation As Integer
On Error GoTo GetFilePath_Error
If Len(FilePath) = 0 Then
GetFilePath = ""
Exit Function
End If
'Find the last \ in the path
slashLocation = InStrRev(FilePath, "\")
If slashLocation = 0 Then
GetFilePath = ""
Else
GetFilePath = Mid$(FilePath, 1, slashLocation)
End If
ExitHere:
On Error GoTo 0
Exit Function
GetFilePath_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetFilePath of Form Form1"
End Function
- How to Retrieve the File Name from a Path
- Code:
Option Explicit
Public Function GetFileName(FilePath As String) As String
Dim slashLocation As Integer
On Error GoTo GetFileName_Error
If Len(FilePath) = 0 Then
GetFileName = ""
Exit Function
End If
'Find the last \ in the path
slashLocation = InStrRev(FilePath, "\")
GetFileName = Mid$(FilePath, slashLocation + 1, Len(FilePath) + 1 - slashLocation)
ExitHere:
On Error GoTo 0
Exit Function
GetFileName_Error:
GetFileName = ""
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetFileName of Form Form1"
End Function
- How to Open a File and return the File Number
- Code:
Option Explicit
Public Function OpenFile(ByVal FilePath As String) As Long
On Error GoTo OpenFile_Error
If Len(Dir$(FilePath)) = 0 Then
OpenFile = -1
Exit Function
End If
OpenFile = FreeFile
Open FilePath For Input As #OpenFile
ExitHere:
On Error GoTo 0
Exit Function
OpenFile_Error:
OpenFile = -2
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure OpenFile of Form Form1"
End Function
Alen1.1- Super Administrator
- Jumlah posting : 82
Age : 33
Fakultas : Fasilkom
Jurusan : sistem informasi
Interest in : Visual Basic,xna,C#
Registration date : 07.01.09
by Alen1.1 Sat Jan 17, 2009 2:18 am
File/Folders Handling 4
- How to scan folders for Files (in two ways)
- Code:
'Method 1
'Place a command button and a list box on a form
Option Explicit
Dim FSys As FileSystemObject
'Constant Value Description for FileAttributes
'Normal 0 Normal file. No attributes are set.
'ReadOnly 1 Read-only file. Attribute is read/write.
'Hidden 2 Hidden file. Attribute is read/write.
'System 4 System file. Attribute is read/write.
'Volume 8 Disk drive volume label. Attribute is read-only.
'Directory 16 Folder or directory. Attribute is read-only.
'Archive 32 File has changed since last backup. Attribute is read/write.
'Alias 64 Link or shortcut. Attribute is read-only.
'Compressed 128 Compressed file. Attribute is read-only.
Function ScanFolder(FolderSpec As String, SearchStr As String) As String
Dim thisFolder As Folder
Dim allFolders As Folders
Dim thisFile As File
Dim allFiles As Files
Set thisFolder = FSys.GetFolder(FolderSpec)
Set allFolders = thisFolder.SubFolders
For Each thisFolder In allFolders
If (thisFolder.Attributes And Hidden) <> Hidden Then ' Leave hidden directories alone
Set allFiles = thisFolder.Files
If allFiles.Count > 0 Then
For Each thisFile In allFiles
If Right(thisFile.Name, 4) = SearchStr Then
List1.AddItem thisFolder.Path & "\" & thisFile.Name
End If
Next
End If
Set allFiles = Nothing
Call ScanFolder(thisFolder.Path, SearchStr)
End If
DoEvents
Next
Set thisFolder = Nothing
Set allFolders = Nothing
Exit Function
End Function
Private Sub Command1_Click()
Dim StartTime As String
List1.Clear
StartTime = Now
MousePointer = vbHourglass
Call ScanFolder("C:\", ".vbp")
MousePointer = vbHourglass
MsgBox "ScanFolders Complete - " & DateDiff("s", StartTime, Now) & " Seconds"
End Sub
Private Sub Form_Load()
Set FSys = New FileSystemObject
End Sub
'Method 2
'Using API
Option Explicit
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Function ScanFolder(Path As String, SearchStr As String) As String
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer
Dim FileSize As Long
Dim FoundName As String
DoEvents
If Right(Path, 1) <> "\" Then Path = Path & "\"
' Search for subdirectories.
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(Path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = StripNulls(WFD.cFileName)
' Ignore the current and encompassing directories.
If (DirName <> ".") And (DirName <> "..") Then
' Check for directory with bitwise comparison.
If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
dirNames(nDir) = DirName
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
DoEvents
Loop
Cont = FindClose(hSearch)
End If
' Walk through this directory and sum file sizes.
hSearch = FindFirstFile(Path & SearchStr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
FileName = StripNulls(WFD.cFileName)
List1.AddItem Path & FileName
Cont = FindNextFile(hSearch, WFD) ' Get next file
DoEvents
Wend
Cont = FindClose(hSearch)
End If
If hSearch = -1 Then
' If there are sub-directories...
If nDir > 0 Then
' Recursively walk into them...
For i = 0 To nDir - 1
FoundName = ScanFolder(Path & dirNames(i) & "\", SearchStr)
If FoundName <> "" Then
ScanFolder = FoundName
Exit Function
End If
DoEvents
Next i
End If
End If
DoEvents
End Function
Private Function StripNulls(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = OriginalStr
End Function
Private Sub Command1_Click()
Dim StartTime As String
List1.Clear
StartTime = Now
MousePointer = vbHourglass
Call ScanFolder("C:\", "*.vbp")
MousePointer = vbNormal
MsgBox "ScanFolders Complete - " & DateDiff("s", StartTime, Now) & " Seconds"
End Sub
- How to Recursive Search for Folders (single drive)
- Code:
'Create a new project with a form containing four text boxes (Text1, Text2, Text3, Text4), a check
'boxes (Check1), a list box (List1) and a command button(Command1). Label as desired and add the
'following code:
Option Explicit
Private Const vbDot = 46
Private Const MAXDWORD As Long = &HFFFFFFFF
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type FILE_PARAMS
bRecurse As Boolean
sFileRoot As String
sFileNameExt As String
sResult As String
sMatches As String
Count As Long
End Type
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Command1_Click()
Dim FP As FILE_PARAMS 'holds search parameters
Dim tstart As Single 'timer var for this routine only
Dim tend As Single 'timer var for this routine only
'clear results textbox and list
Text3.Text = ""
'set up search params
With FP
.sFileRoot = Text1.Text 'start path
.sFileNameExt = Text2.Text 'file type of interest
.bRecurse = Check1.Value = 1 '1 = do recursive search
End With
'setting the list visibility to false
'increases clear and load time
List1.Visible = False
List1.Clear
'get start time, folders, and finish time
tstart = GetTickCount()
Call SearchForFolders(FP)
tend = GetTickCount()
List1.Visible = True
'show the results
Text3.Text = Format$(FP.Count, "###,###,###,##0") & " found (" & FP.sFileNameExt & ")"
Text4.Text = FormatNumber((tend - tstart) / 1000, 2) & " seconds"
End Sub
Private Sub SearchForFolders(FP As FILE_PARAMS)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
Dim sRoot As String
Dim spath As String
Dim sTmp As String
sRoot = QualifyPath(FP.sFileRoot)
spath = sRoot & FP.sFileNameExt
'obtain handle to the first match
hFile = FindFirstFile(spath, WFD)
'if valid ...
If hFile <> INVALID_HANDLE_VALUE Then
Do
'Only folders are wanted, so discard files
'or parent/root DOS folders.
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) And _
Asc(WFD.cFileName) <> vbDot Then
'must be a folder, so remove trailing nulls
sTmp = TrimNull(WFD.cFileName)
'This is where you add code to store
'or display the returned file listing.
'if you want the folder name only, save 'sTmp'.
'if you want the full path, save 'sRoot & sTmp'
FP.Count = FP.Count + 1
List1.AddItem sRoot & sTmp
'if a recursive search was selected, call
'this method again with a modified root
If FP.bRecurse Then
FP.sFileRoot = sRoot & sTmp
Call SearchForFolders(FP)
End If
End If
Loop While FindNextFile(hFile, WFD)
'close the handle
hFile = FindClose(hFile)
End If
End Sub
Private Function TrimNull(startstr As String) As String
'returns the string up to the first null, if present, or the passed string
Dim pos As Integer
pos = InStr(startstr, Chr$(0))
If pos Then
TrimNull = Left$(startstr, pos - 1)
Exit Function
End If
TrimNull = startstr
End Function
Private Function QualifyPath(spath As String) As String
'assures that a passed path ends in a slash
If Right$(spath, 1) <> "\" Then
QualifyPath = spath & "\"
Else
QualifyPath = spath
End If
End Function
- How to list all files in a given directory
- Code:
Private Sub ListFiles(ByVal sPath As String, ByVal sExt As String)
Dim sCurDir As String, sFile As String
Dim colFolders As New Collection
colFolders.Add IIf(Right(sPath, 1) = "\", sPath, sPath & "\")
Do While colFolders.Count
sCurDir = colFolders.Item(1)
colFolders.Remove 1
sFile = Dir$(sCurDir, vbDirectory)
Do While Len(sFile)
If Not (sFile = "." Or sFile = "..") Then
If (GetAttr(sCurDir & sFile) Or vbDirectory) = vbDirectory Then
colFolders.Add sCurDir & sFile & "\"
Else
If UCase$(Right$(sFile, Len(sExt) + 1)) = "." & UCase$(sExt) Then
Text1.Text = Text1.Text & sCurDir & sFile & vbCrLf
End If
End If
End If
sFile = Dir
Loop
Loop
End Sub
'How to call this function:
'Call ListFiles("C:\Temp\", "txt")
- How to set attributes to the files
- Code:
Sub SetAttrib()
' Mark a file as Archive and Read-only.
filename = "d:\VS98\Temporary.Dat"
SetAttr filename, vbArchive + vbReadOnly
' Change a file from hidden to visible, and vice versa.
SetAttr filename, GetAttr(filename) Xor vbHidden
End Sub
- How to Rename the files
- Code:
Sub FileOperations()
' All file operations should be protected against errors.
' None of these functions works on open files.
On Error Resume Next
' Rename a file--note that you must specify the path in the target,
' otherwise the file will be moved to the current directory.
Name "c:\vb6\TempData.tmp" As "c:\vb6\TempData.$$$"
End Sub
- How to Move the files
- Code:
Sub FileOperations()
' All file operations should be protected against errors.
' None of these functions works on open files.
On Error Resume Next
' Rename a file--note that you must specify the path in the target,
' otherwise the file will be moved to the current directory.
Name "c:\vb6\TempData.$$$" As "d:\VS98\Temporary.Dat"
End Sub
- How to Copy the files to another directory (in three ways)
- Code:
'Using FileCopy:
Public Sub CopyFileUsingFileCopy(ByVal sSourceFile As String, ByVal sDestinationFile As String)
'All file operations should be protected against errors.
'None of these functions works on open files.
On Error Resume Next
'By default it will overwrite the existting file
FileCopy sSourceFile, sDestinationFile
End Sub
'Using FSO:
Public Sub CopyFileUsingFSO(ByVal sSourceFile As String, ByVal sDestinationFile As String, _
Optional ByVal bOverWrite As Boolean = True)
'Set a reference to "Microsoft scripting Runtime"
' All file operations should be protected against errors.
' None of these functions works on open files.
On Error Resume Next
' Make a copy of a file--note that you can change the name during the copy
' and that you can omit the filename portion of the target file.
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
FSO.CopyFile sSourceFile, sDestinationFile, bOverWrite
Set FSO = Nothing
End Sub
'Using API:
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Public Sub CopyFileUsingAPI(ByVal sSourceFile As String, ByVal sDestinationFile As String, _
Optional ByVal bFailIfExists As Boolean = False)
Call CopyFile(sSourceFile, sDestinationFile, bFailIfExists)
End Sub
- How to Create folder
- Code:
'Using MkDir:
Public Sub CreateFolderUsingMkDir(ByVal sFolderName As String)
MkDir sFolderName
End Sub
'Using FSO:
Public Sub CreateFolderUsingFSO(ByVal sFolderName As String)
'Set a reference to "Microsoft scripting Runtime"
Dim FSO As scripting.FileSystemObject
Set FSO = New scripting.FileSystemObject
FSO.CreateFolder sFolderName
Set FSO = Nothing
End Sub
by Sponsored content
