Visual Basic Codes
Visual Basic > Applications-VBA sample source codes

All File Operations

All File Operations

Option Explicit
 Private Declare Function ShellExecute Lib "shell32.dll" Alias _
           "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
           String, ByVal lpszFile As String, ByVal lpszParams As String, _
           ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
             Private Declare Function GetDesktopWindow Lib "user32" () As Long

           Const SW_SHOWNORMAL = 1

           Const SE_ERR_FNF = 2&
           Const SE_ERR_PNF = 3&
           Const SE_ERR_ACCESSDENIED = 5&
           Const SE_ERR_OOM = 8&
           Const SE_ERR_DLLNOTFOUND = 32&
           Const SE_ERR_SHARE = 26&
           Const SE_ERR_ASSOCINCOMPLETE = 27&
           Const SE_ERR_DDETIMEOUT = 28&
           Const SE_ERR_DDEFAIL = 29&
           Const SE_ERR_DDEBUSY = 30&
           Const SE_ERR_NOASSOC = 31&
           Const ERROR_BAD_FORMAT = 11&
Function StartDoc(DocName As String) As Long
                   Dim Scr_hDC As Long
                   Scr_hDC = GetDesktopWindow()
                   StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
                   "", "C:\", SW_SHOWNORMAL)
End Function
     
Function File_Copy(strCopyFrom As String, strCopyTo As String)
       FileCopy strCopyFrom, strCopyTo
End Function

Function Current_Dir() As String
       Current_Dir = CurDir
End Function

Function Change_Dir(strChangeTo As String)
       ChDir strChangeTo
End Function
Function Change_Drive(strChangeTo As String) As String
       ChDrive (strChangeTo)
       Change_Drive = CurDir
End Function
Function File_Exists(strToCheck As String) As Integer
       
       Dim retval As String
       
       retval = Dir$(strToCheck)
       
       If retval = strToCheck Then
               File_Exists = 1
       Else
               File_Exists = 0
       End If

End Function
Function File_Rename(strOldName As String, strNewName As String)
       Name strOldName As strNewName
End Function
Function File_Delete(strToDelete As String)
       Kill strToDelete
End Function
Function Create_Dir(strToCreate)
       MkDir strToCreate
End Function
Function Remove_Dir(strToRemove As String)
       RmDir strToRemove
End Function
Function File_Move(strMoveFrom As String, strMoveTo As String)
               Kill strMoveTo
               FileCopy strMoveFrom, strMoveTo
End Function
Function File_ReadLine(strToRead As String, LineNum As Integer) As String

       Dim intCtr As Integer
       Dim strValue As String
       Dim intFNum As Integer
       Dim intMsg As Integer
 
       
       intFNum = FreeFile
       Open strToRead For Input As #intFNum
               
                 intCtr = LineNum
                 Input #intFNum, strValue
                 File_ReadLine = strValue
                                           
       Close #intFNum
       
End Function
Function Run_Application(strPathOfFile As String)
       Dim r As Long, msg As String
                   r = StartDoc(strPathOfFile)
                   If r <= 32 Then
                           'There was an error
                           Select Case r
                                   Case SE_ERR_FNF
                                           msg = "File not found"
                                   Case SE_ERR_PNF
                                           msg = "Path not found"
                                   Case SE_ERR_ACCESSDENIED
                                           msg = "Access denied"
                                   Case SE_ERR_OOM
                                           msg = "Out of memory"
                                   Case SE_ERR_DLLNOTFOUND
                                           msg = "DLL not found"
                                   Case SE_ERR_SHARE
                                           msg = "A sharing violation occurred"
                                   Case SE_ERR_ASSOCINCOMPLETE
                                           msg = "Incomplete or invalid file association"
                                   Case SE_ERR_DDETIMEOUT
                                           msg = "DDE Time out"
                                   Case SE_ERR_DDEFAIL
                                           msg = "DDE transaction failed"
                                   Case SE_ERR_DDEBUSY
                                           msg = "DDE busy"
                                   Case SE_ERR_NOASSOC
                                           msg = "No association for file extension"
                                   Case ERROR_BAD_FORMAT
                                           msg = "Invalid EXE file or error in EXE image"
                                   Case Else
                                           msg = "Unknown error"
                           End Select
                           
                   End If
           
End Function
Function File_Time(strFileName As String) As String

       Dim strDate As String
       Dim intcount, intDateLen As Integer
       
       strDate = FileDateTime(strFileName)
       intcount = InStr(1, strDate, " ", vbTextCompare)
       intDateLen = Len(strDate)
       File_Time = Mid$(strDate, intcount + 1, intDateLen)
       
End Function
Function File_Date(strFileName As String) As String

       Dim strDate As String
       Dim intcount As Integer
       
       strDate = FileDateTime(strFileName)
       intcount = InStr(1, strDate, " ", vbTextCompare)
       File_Date = CDate(Mid$(strDate, 1, intcount))
       
End Function