January 8, 2004
@ 01:12 AM
Comments [0]
Create Unique Temporary File Names

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


 
Categories: VB

« Copying Rows In Access | Home | Dealing with Null Database Fields »
Comments are closed.