' ========================================================================================================================
' ____,__, __, ____,_, _, ____ ____,__, ,____,____,
' (-/_|(-| (-| (-|_,(-|\ | (-|__|-/_|( |_/(-|_,(-|__)
' _/ |,_|__,_|__,_|__,_| \|, _|__)/ |,_| \,_|__,_| \,
'
' Copyright � 2009 Allen Baker
'
' ------------------------------------------------------------------------------------------------------------------------
' File: M021_File
' Originator: Allen Baker (2009.11.21 15:54)
' ------------------------------------------------------------------------------------------------------------------------
' $RCSfile$
' $Revision$
' $Date$
' ========================================================================================================================
'
Option Explicit
' ========================================================================================================================
' Description
' This module provides procedures that supplement the File type.
' ========================================================================================================================
' =====================================================================================================================
' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@[ Constants ]@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
' =====================================================================================================================
' =====================================================================================================================
' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<[ Miscellaneous ]>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' =====================================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function opens an XLS file. It displays the File Open box. You can naviagate to a directory, select
' the file and then click Open. The file you selected will open up in Excel.
' -----------------------------------------------------------------------------------------------------------
Public Function openXLSFile()
openXLSFile = openFile("XLS")
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function opens an CSV file. It displays the File Open box. You can naviagate to a directory, select
' the file and then click Open. The file you selected will open up in Excel.
' -----------------------------------------------------------------------------------------------------------
Public Function openCSVFile() As String
openCSVFile = openFile("CSV")
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function opens a file. It displays the File Open box. You can naviagate to a directory, select the
' file and then click Open. The file you selected will open up in Excel.
'
' return
' this function returns the name of the file that was opened
'
' param
' pFileType is a string that specifies the file extension for the file to open.
' -----------------------------------------------------------------------------------------------------------
Public Function openFile(pFileType As String) As String
Dim fileName As Variant
Dim fileNameString As String
Dim fileType As String
gMsg(1) = ""
fileType = UCase(pFileType)
'
' ==============================================================================================
' display the file open box
' ----------------------------------------------------------------------------------------------
Select Case fileType
Case "XLS"
fileName = Application.GetOpenFilename(FileFilter:="Excel Text Files (*.csv), *.csv", Title:="Please select a file")
Case "CSV"
fileName = Application.GetOpenFilename(FileFilter:="Excel Text Files (*.csv), *.csv", Title:="Please select a file")
Case Else
fileName = Application.GetOpenFilename(FileFilter:="All Files (*.*), *.*", Title:="Please select a file")
End Select
'
' ==============================================================================================
' if they did not select a file (they pressed cancel), just exit
' ----------------------------------------------------------------------------------------------
If fileName = False Then
openFile = ""
'
' ==============================================================================================
' otherwise they did select a file so open it.
' ----------------------------------------------------------------------------------------------
Else
fileNameString = fileName
openFile = openNamedFile(fileNameString)
End If
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function opens a specified file.
'
' return
' this function returns the name of the file that was opened or if the file does not exist, it returns
' the empty string.
'
' param
' pFileType is a string that specifies the filename of the file to open.
' -----------------------------------------------------------------------------------------------------------
Public Function openNamedFile(pFilePath As String) As String
gMsg(1) = ""
On Error GoTo ErrHandler
If fileExists(pFilePath) Then
Workbooks.Open fileName:=pFilePath
openNamedFile = pFilePath
Else
gMsg(1) = "openNamedFile(" & pFilePath & "): File does not exist."
openNamedFile = ""
End If
Exit Function
ErrHandler:
gMsg(1) = "openNamedFile(" & pFilePath & "): " & Err.Description
openNamedFile = ""
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function deletes all the files that match a filename spec. deleteFile supports the use of
' multiple-character (*) and single-character (?) wildcards to specify multiple files
'
' return
' True if all matching files are deleted, False if not.
'
' param
' pFilePathSpec is a string expression that specifies one or more filenames to be deleted. pFilePathSpec
' may include the directory or folder and the drive
' -----------------------------------------------------------------------------------------------------------
Public Function deleteFile(pFilePathSpec As String) As Boolean
gMsg(1) = ""
On Error GoTo ErrHandler
Kill pFilePathSpec
deleteFile = Not fileExists(pFilePathSpec)
If Not deleteFile Then gMsg(1) = "deleteFile(" & pFilePathSpec & "): Delete failed."
Exit Function
ErrHandler:
gMsg(1) = "deleteFile(" & pFilePathSpec & "): " & Err.Description
deleteFile = False
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function renames the specified file. renameFile does not support the use of multiple-character (*)
' and single-character (?) wildcards to specify multiple files
'
' return
' True if the file was successfully renamed, False if not.
'
' param
' pOldFilePath is the pathname of the file to rename.
' param
' pNewFilePath is the pathname to rename the file to.
' -----------------------------------------------------------------------------------------------------------
Public Function renameFile(pOldFilePath As String, pNewFilePath As String) As Boolean
gMsg(1) = ""
On Error GoTo ErrHandler
Name pOldFilePath As pNewFilePath
renameFile = (Not fileExists(pOldFilePath)) And (fileExists(pNewFilePath))
If Not renameFile Then gMsg(1) = "renameFile(" & pOldFilePath & " " & pNewFilePath & "): Rename failed."
Exit Function
ErrHandler:
gMsg(1) = "renameFile: " & Err.Description
renameFile = False
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function copys the specified file. copyFile does not support the use of multiple-character (*) and
' single-character (?) wildcards to specify multiple files
'
' return
' True if the file was successfully copied, False if not.
'
' param
' pSourceFilePath is the pathname of the file to copy.
' param
' pDestinationFilePath is the pathname to copy the file to.
' -----------------------------------------------------------------------------------------------------------
Public Function copyFile(pSourceFilePath As String, pDestinationFilePath As String) As Boolean
gMsg(1) = ""
On Error GoTo ErrHandler
Call FileCopy(pSourceFilePath, pDestinationFilePath)
copyFile = _
( _
fileExists(pSourceFilePath) And _
fileExists(pDestinationFilePath) And _
filesAreEqual(pSourceFilePath, pDestinationFilePath) _
)
If Not copyFile Then gMsg(1) = "copyFile(" & pSourceFilePath & " " & pDestinationFilePath & "): Copy failed."
Exit Function
ErrHandler:
gMsg(1) = "copyFile: " & Err.Description
copyFile = False
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine accepts two strings that represent two files to compare. A return value of True indicates
' that the contents of the files are the same. A return value of False indicates that the files are not the
' same.
'
' return
' True if the files are equal, False if not.
'
' param
' pFilePath1 is the pathname of the file to compare to the file at pFilePath2
' param
' pFilePath2 is the pathname of the file to compare to the file at pFilePath1
' -----------------------------------------------------------------------------------------------------------
Public Function filesAreEqual(pFilePath1 As String, pFilePath2 As String) As Boolean
Const cChunkSize As Long = 1000
Dim file1 As Integer
Dim file2 As Integer
Dim numChunks As Long
Dim bytesRemaining As Long
Dim thisChunk As Long
Dim buffer1 As String * cChunkSize
Dim buffer2 As String * cChunkSize
gMsg(1) = ""
'
' ==============================================================================================
' if the filenames passed in are not empty, open the files
' ----------------------------------------------------------------------------------------------
If Len(Dir$(pFilePath1)) > 0 And Len(Dir$(pFilePath2)) > 0 Then
On Error GoTo ErrFailed
file1 = FreeFile
Open pFilePath1 For Binary Access Read As file1
file2 = FreeFile
Open pFilePath2 For Binary Access Read As file2
'
' ==============================================================================================
' Files are a different size
' ----------------------------------------------------------------------------------------------
If LOF(file1) <> LOF(file2) Then
filesAreEqual = False
'
' ==============================================================================================
' Files are same size
' ----------------------------------------------------------------------------------------------
Else
numChunks = LOF(file1) \ cChunkSize
bytesRemaining = LOF(file1) Mod cChunkSize 'Remaining number of bytes
'
' ==============================================================================================
' Loop over the files reading in chunks of data and comparing them
' ----------------------------------------------------------------------------------------------
For thisChunk = 1 To numChunks
Get file1, cChunkSize * (thisChunk - 1) + 1, buffer1
Get file2, cChunkSize * (thisChunk - 1) + 1, buffer2
'
' ==============================================================================================
' Files are different
' ----------------------------------------------------------------------------------------------
If Not (buffer1 = buffer2) Then
filesAreEqual = False
Exit For
End If
Next
'
' ==============================================================================================
' Check last chunk of data
' ----------------------------------------------------------------------------------------------
If thisChunk = numChunks + 1 Then
Get file1, (cChunkSize * numChunks) + 1, buffer1 'get the bytesRemaining bytes at the end
Get file2, (cChunkSize * numChunks) + 1, buffer2 'get the bytesRemaining bytes at the end
'
' ==============================================================================================
' Files are different
' ----------------------------------------------------------------------------------------------
If Not Left$(buffer1, bytesRemaining) = Left$(buffer2, bytesRemaining) Then
filesAreEqual = False
'
' ==============================================================================================
' File are identical
' ----------------------------------------------------------------------------------------------
Else
filesAreEqual = True
End If
End If
End If
'
' ==============================================================================================
' Close files
' ----------------------------------------------------------------------------------------------
Close file1
Close file2
'
' ==============================================================================================
' Files don't exist
' ----------------------------------------------------------------------------------------------
Else
filesAreEqual = False
End If
Exit Function
ErrFailed:
gMsg(1) = "filesAreEqual: " & Err.Description
filesAreEqual = False
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function checks to see if any files matching the filename spec exist. If any do, then this function
' returns true, otherwise, it returns False. fileExists supports the use of multiple-character (*) and
' single-character (?) wildcards to specify multiple files
'
' return
' True if any matching files exist, False if not.
'
' param
' pFilePathSpec is a string expression that specifies one or more filenames to look for. pFilePathSpec
' may include the directory or folder and the drive
' -----------------------------------------------------------------------------------------------------------
Public Function fileExists(pFilePathSpec As String) As Boolean
fileExists = (Dir$(pFilePathSpec, vbNormal + vbHidden + vbSystem) <> vbNullString)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function checks to see if any directories matching the directory path spec exist. If any do, then
' this function returns true, otherwise, it returns False. directoryExists supports the use of
' multiple-character (*) and single-character (?) wildcards to specify multiple directories
'
' return
' True if any matching directories exist, False if not.
'
' param
' pDirPathSpec is a string expression that specifies one or more directory paths to look for.
' pDirPathSpec may include the directory or folder and the drive
' -----------------------------------------------------------------------------------------------------------
Public Function directoryExists(pDirPathSpec As String) As Boolean
directoryExists = (Dir$(pDirPathSpec, vbDirectory + vbHidden + vbSystem) <> vbNullString)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function strips away the path from a filename giving the workbook name of the file
'
' return
' this function returns a workbook name
'
' param
' pFilePath is the pathname of the file from which a wookbook name is derived
' -----------------------------------------------------------------------------------------------------------
Public Function workbookNameFromFileName(pFilePath As String) As String
Dim idx As Long
idx = InStrRev(pFilePath, "\")
workbookNameFromFileName = Right(pFilePath, Len(pFilePath) - idx)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function strips away the extension from a filename
'
' return
' this function returns an extensionless name
'
' param
' pFilePath is the pathname of the file from which extension is removed
' -----------------------------------------------------------------------------------------------------------
Public Function extensionlessFileName(pFilePath As String) As String
Dim idx As Long
idx = InStrRev(pFilePath, ".")
extensionlessFileName = Left(pFilePath, idx - 1)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function strips away the directory path from a filename
'
' return
' this function returns an directoryless name
'
' param
' pFilePath is the pathname of the file from which the directory path is removed
' -----------------------------------------------------------------------------------------------------------
Public Function directorylessFileName(pFilePath As String) As String
directorylessFileName = Mid(pFilePath, InStrRev(pFilePath, "\") + 1)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function strips away the extension from a filename and also strips away the directory path from the
' fron of the filename.
'
' return
' this function returns an extensionless and directoryless name
'
' param
' pFilePath is the pathname of the file from which extension and directory is removed
' -----------------------------------------------------------------------------------------------------------
Public Function directorylessAndExtensionlessFileName(pFilePath As String) As String
Dim strTemp As String
strTemp = Mid(pFilePath, InStrRev(pFilePath, "\") + 1)
directorylessAndExtensionlessFileName = Left(strTemp, InStrRev(strTemp, ".") - 1)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function gets the extension portion of a filename
'
' return
' this function returns filename's extension
'
' param
' pFilePath is the pathname of the file from which extension is removed
' -----------------------------------------------------------------------------------------------------------
Public Function fileNameExtension(pFilePath As Variant) As String
Dim strTemp As String
Dim strTemp2 As String
Dim intPos As Integer
If IsNull(pFilePath) Then
strTemp = ""
Else
strTemp2 = pFilePath
intPos = InStrRev(strTemp2, ".")
If intPos = 0 Then
strTemp = ""
Else
If intPos = Len(strTemp2) Then
strTemp = ""
Else
strTemp = Mid(strTemp2, intPos + 1)
End If
End If
End If
fileNameExtension = strTemp
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function gets the folder portion (i.e. the directory path only) of a filename
'
' return
' this function returns filename's folder
'
' param
' pFilePath is the pathname of the file from which folder is returned
' -----------------------------------------------------------------------------------------------------------
Public Function folder(pFilePath As String) As String
folder = Left(pFilePath, InStrRev(pFilePath, "\"))
End Function
Facebook