HIMSISFO

Himpunan Mahasiswa Sistem Informasi Universitas Mercubuana


    VB6 Code Bank: File, Folders & Text File Handling, Date & Time

    Share
    avatar
    Alen1.1
    Super Administrator
    Super Administrator

    Male Jumlah posting : 82
    Age : 28
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09

    VB6 Code Bank: File, Folders & Text File Handling, Date & Time

    Post by Alen1.1 on Sat Jan 17, 2009 1:56 am

    File/Folders Handling 1


    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




    2. 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




    3. 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")




    4. 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")




    5. 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




    6. 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




    7. 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")




    8. 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




    9. 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




    10. 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
    avatar
    Alen1.1
    Super Administrator
    Super Administrator

    Male Jumlah posting : 82
    Age : 28
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09

    Re: VB6 Code Bank: File, Folders & Text File Handling, Date & Time

    Post by Alen1.1 on Sat Jan 17, 2009 1:59 am

    File/Folders Handling 2


    1. 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
    2. 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
    3. 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
    4. 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
    5. 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
    6. 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")
    7. 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
    8. 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")
    9. 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
    10. 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
    avatar
    Alen1.1
    Super Administrator
    Super Administrator

    Male Jumlah posting : 82
    Age : 28
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09

    Re: VB6 Code Bank: File, Folders & Text File Handling, Date & Time

    Post by Alen1.1 on Sat Jan 17, 2009 2:12 am

    File/Folders Handling 3


    1. 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




    2. 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




    3. How to find the Date and time of the file

      Code:
      Debug.Print FileDateTime("d:\VS98\Temporary.Dat")    ' Returns a Date value




    4. 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"




    5. 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




    6. 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




    7. 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




    8. 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




    9. 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




    10. 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
    avatar
    Alen1.1
    Super Administrator
    Super Administrator

    Male Jumlah posting : 82
    Age : 28
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09

    Re: VB6 Code Bank: File, Folders & Text File Handling, Date & Time

    Post by Alen1.1 on Sat Jan 17, 2009 2:18 am

    File/Folders Handling 4


    1. 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




    2. 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




    3. 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")




    4. 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




    5. 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




    6. 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




    7. 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




    8. 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

    Sponsored content

    Re: VB6 Code Bank: File, Folders & Text File Handling, Date & Time

    Post by Sponsored content


      Waktu sekarang Sun Jul 22, 2018 4:19 am