Here's a couple of functions that may be useful to you.
Option Compare Database 'Use database order for string comparisons
Option Explicit
Function CopyDir(SourcePath As String, DestPath As String) As Integer
'
' Copies files in SourcePath to DestPath
' Does not copy any subdirectories of SourcePath
'
' Calling Convention:
' X = CopyDir("C:\Temp", "A:")
'
Dim filename As String, Copied As Integer
filename = Dir(SourcePath & "\*.*")
Do While filename <> ""
Copied = CopyFile(SourcePath & "\" & filename, DestPath & "\" & filename)
If Not Copied Then
CopyDir = False
Exit Function
End If
filename = Dir
Loop
CopyDir = True
End Function
Function CopyFile(SourceName As String, DestName As String) As Integer
'
' Copies a single file SourceName to DestName
'
' Calling convention:
' X = CopyFile("C:\This.Exe", "C:\That.Exe")
' X = CopyFile("C:\This.Exe", "C:\Temp\This.Exe")
'
Const BufSize = 8192
Dim Buffer As String * BufSize, TempBuf As String
Dim SourceF As Integer, DestF As Integer, i As Long
On Error GoTo CFError
SourceF = FreeFile
Open SourceName For Binary As #SourceF
DestF = FreeFile
Open DestName For Binary As #DestF
For i = 1 To LOF(SourceF) \ BufSize
Get #SourceF, , Buffer
Put #DestF, , Buffer
Next i
i = LOF(SourceF) Mod BufSize
If i > 0 Then
Get #SourceF, , Buffer
TempBuf = Left$(Buffer, i)
Put #DestF, , TempBuf
End If
Close #SourceF
Close #DestF
CopyFile = True
CFExit:
Exit Function
CFError:
Close
MsgBox "Error " & Err.Number & " copying files" & Chr$(13) & Chr$(10) & Error
CopyFile = False
Resume CFExit
End Function
Sub FDeleteLine(ByVal PathName As String, ByVal LineToDelete As String)
'
' Deletes a line (LineToDelete) from a text file.
' This must be an exact match. If not found, doesn't return an error.
'
Dim f As Integer, F2 As Integer, InLine As String, FName2 As String
Dim Drive As String, Path As String, filename As String, Ext As String
FParsePath PathName, Drive, Path, filename, Ext
FName2 = Drive & Path & Format(Time, "hhnnss") & ".TMP"
f = FreeFile
Open PathName For Input As #f
F2 = FreeFile
Open FName2 For Output As #F2
Do While Not EOF(f)
Line Input #f, InLine
If InLine <> LineToDelete Then
Print #F2, InLine
End If
Loop
Close #f
Close #F2
'
' Replace old file with new file
'
Kill PathName
Name FName2 As PathName
End Sub
Sub FInsertLine(ByVal PathName As String, ByVal LineToAdd As String, ByVal LineToAddAfter As String)
'
' Inserts a line in a text file after a specified line.
' If LineToAddAfter is blank, then add to the front of the file.
'
Dim f As Integer, F2 As Integer, InLine As String, FName2 As String
Dim Drive As String, Path As String, filename As String, Ext As String
FParsePath PathName, Drive, Path, filename, Ext
FName2 = Drive & Path & Format(Time, "hhnnss") & ".TMP"
f = FreeFile
Open PathName For Input As #f
F2 = FreeFile
Open FName2 For Output As #F2
'
' Check to see if add to front of the file
'
If LineToAddAfter = "" Then
Print #F2, LineToAdd
End If
'
' Copy the file a line at a time
'
Do While Not EOF(f)
Line Input #f, InLine
Print #2, InLine
If LineToAddAfter <> "" Then ' Check to see if line has been added yet
If InLine = LineToAddAfter Then ' Check to see if we've reached the majic line
Print #F2, LineToAdd ' Add the line
LineToAddAfter = "" ' Prevent from being added multiple times
End If
End If
Loop
Close #f
Close #F2
'
' Replace old file with new file
'
Kill PathName
Name FName2 As PathName
End Sub
Sub FParseFullPath(ByVal FullPath As String, Drive As String, DirName As String, fName As String, Ext As String)
'
' Parses drive, directory, filename, and extension into separate variables.
'
' Assumptions/Gotcha's:
' 1. If a drive letter isn't specified, returns the current drive.
' 2. If the directory doesn't start from the root, prepends the current directory name
' for the current/selected drive. This could cause problems if the selected drive
' doesn't exist on this machine.
'
Dim i As Integer, f As String, Found As Integer
Drive = Left$(CurDir, 2) ' Current drive if none explicitly specified
DirName = ""
fName = ""
Ext = ""
FullPath = Trim$(FullPath)
'
' Get drive letter
'
If Mid$(FullPath, 2, 1) = ":" Then
Drive = Left$(FullPath, 2)
FullPath = Mid$(FullPath, 3)
End If
'
' Get directory name
'
f = ""
Found = False
For i = Len(FullPath) To 1 Step -1
If Mid$(FullPath, i, 1) = "\" Then
f = Mid$(FullPath, i + 1)
DirName = Left$(FullPath, i)
Found = True
Exit For
End If
Next i
If Not Found Then
f = FullPath
End If
'
' Add current directory of selected drive if absolute directory not specified
'
If DirName = "" Or Left$(DirName, 1) <> "\" Then
DirName = Mid$(CurDir(Left$(Drive, 1)), 3) & "\" & DirName
End If
'
' Get File name and extension
'
If f = "." Or f = ".." Then
fName = f
Else
i = InStr(f, ".")
If i > 0 Then
fName = Left$(f, i - 1)
Ext = Mid$(f, i)
Else
fName = f
End If
End If
End Sub
Sub FParsePath(ByVal FullPath As String, Drive As String, DirName As String, fName As String, Ext As String)
'
' Parses drive, directory, filename, and extension into separate variables.
' Returns blank drive letter/path if none specified.
'
Dim i As Integer, f As String, Found As Integer
Drive = ""
DirName = ""
fName = ""
Ext = ""
FullPath = Trim$(FullPath)
'
' Get drive letter
'
If Mid$(FullPath, 2, 1) = ":" Then
Drive = Left$(FullPath, 2)
FullPath = Mid$(FullPath, 3)
End If
'
' Get directory name
'
f = ""
Found = False
For i = Len(FullPath) To 1 Step -1
If Mid$(FullPath, i, 1) = "\" Then
f = Mid$(FullPath, i + 1)
DirName = Left$(FullPath, i)
Found = True
Exit For
End If
Next i
If Not Found Then
f = FullPath
End If
'
' Get File name and extension
'
If f = "." Or f = ".." Then
fName = f
Else
i = InStr(f, ".")
If i > 0 Then
fName = Left$(f, i - 1)
Ext = Mid$(f, i)
Else
fName = f
End If
End If
End Sub
Function GetMDBSize() As Long
'
' Returns the current size of the current MDB file in bytes.
' The MDB must be opened for shared access for the function to work.
'
Dim db As Database, f As Integer
Set db = CurrentDb()
f = FreeFile
Open db.Name For Binary Shared As #f
GetMDBSize = LOF(f)
Close f
db.Close
End Function
Sub TestFParsePath()
'
' FParseFullPath will crash if drive letter specified is nonexistent
'
Dim Drive As String, DirName As String, fName As String, Ext As String
FParsePath "\program files\microsoft office\office\samples\northwind.mdb", Drive, DirName, fName, Ext
Debug.Print Drive, DirName, fName, Ext
FParseFullPath "\program files\microsoft office\office\samples\northwind.mdb", Drive, DirName, fName, Ext
Debug.Print Drive, DirName, fName, Ext
End Sub
