Although only one function is presented here, you may notice a gold mine of other associated and required functions that may be used for a multitude of purposes.
Code
Public Function GetUniqueFileName(ThisEXT As String, Optional ThisPath As String) As String
Dim retval As String, varTmp As String
varTmp = NormalizePath(GetTEMPdir(True))
Do
If LTrim(RTrim(ThisPath)) <> "" Then
If DirExistCreate(ThisPath, False) Then
retval = NormalizePath(ThisPath) & UniqueFileName & "." & ThisEXT
ElseIf DirExistCreate(varTmp, True) Then
retval = varTmp & UniqueFileName
End If
ElseIf DirExistCreate(varTmp, True) Then
retval = varTmp & UniqueFileName
End If
DoEvents 'give someone else a chance...
Loop While FindFile(retval)
GetUniqueFileName = retval
End Function
Public Function UniqueFileName() As String
On Local Error GoTo ufnError
Dim retval As String
'This example uses the Rnd function to generate a random integer value from 10000 to 32000.
retval = "~" & Str(Int((32000 * Rnd) + 10000))
ufnOut
UniqueFileName = retval
Exit Function
ufnError
retval = ""
Resume ufnOut
End Function
Public Function GetTEMPdir(CreateOne As Boolean, Optional tVar As String) As String
Dim wTmp As String
On Local Error Resume Next
wTmp = Environ$("TEMP") If wTmp = "" Then
If CreateOne Then
If LTrim(RTrim(tVar)) = "" Then tVar = "C\TEMP"
MkDir tVar
wTmp = tVar
End If
End If
wTmp = NormalizePath(wTmp)
GetTEMPdir = wTmp
End Function
Public Function FindFile(ThisFile As String, Optional SetAttribute As Variant) As Boolean
On Local Error GoTo ffError
Dim retval As Boolean, tAttr As Integer
tAttr = vbNormal 'tattr=0
If Trim(ThisFile) = "" Then
Exit Function
End If
Do While tAttr <= 39
If Len(Dir(ThisFile, tAttr)) > 0 Then
If Not IsMissing(SetAttribute) Then
SetAttr ThisFile, CInt(SetAttribute)
End If
retval = True
Exit Do
Else
tAttr = tAttr + 1
'1 -> 7 valid for files
If tAttr = 8 Then tAttr = 32
'32 -> 39 valid for files
If tAttr = 40 Then
retval = False
Exit Do
End If
End If
Loop
ffOut
FindFile = retval
Exit Function
ffError
retval = False
Msg = "Find File Error " & Error(Err) & vbCrLf
Msg = Msg & ThisFile
MsgBox Msg, vbExclamation, App.EXEName
Err = 0
Resume ffOut
End Function
Public Function DirExistCreate(ThisDir As String, Optional CreateIt As Variant) As Boolean
On Local Error GoTo DEerror
Dim Retval As Boolean, varCreateIt As Boolean
Dim ThisTest As String, c As Integer, p As String, i As Integer
Dim b As Integer
TestDiragain
If Trim(ThisDir) <> "" Then
If Not IsMissing(CreateIt) Then varCreateIt = CBool(CreateIt)
If Len(Dir(ThisDir, 16)) > 0 Then
Retval = True
Else
'does not exist so create it by parsing
ThisDir = NormalizePath(ThisDir)
c = InStr(ThisDir, "\")
If c <= 0 Then b = 1 Else b = c + 2
For i = b To Len(ThisDir)
p = Mid(ThisDir, i, 1)
If p = "\" Then
ThisTest = Left(ThisDir, i - 1)
If Len(Dir(ThisTest, 16)) <= 0 Then
MkDir ThisTest
End If
End If
Next
GoTo TestDiragain
End If
End If
DEout
DirExistCreate = Retval
Exit Function
DEerror
Retval = False
LogError Err, "Unable to create directory " & ThisDir
Err = 0
Resume DEout
End Function
Public Function NormalizePath(ThisPath As String) As String
If Right(ThisPath, 1) <> vbNullChar Then
If Right(ThisPath, 1) <> "\" Then
NormalizePath = ThisPath & "\"
Else
NormalizePath = ThisPath
End If
Else
NormalizePath = ThisPath
End If
End Function
Tip Submitted By: Dick Wilson