Source

VB and VBA Code Library / clsTempFolder.cls

Full commit
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsTempFolder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
''
' Class to handle temporary folders
'
' @author   Christoph Juengling <christoph@juengling-edv.de>
' @link   https://bitbucket.org/juengling/vb-and-vba-code-library
'
Option Explicit

Private m_strSubFolder As String
Private fso As Scripting.FileSystemObject
Private m_strWinTempFolder As String

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Property Get getFullPath() As String

getFullPath = fullPath()

End Property

Private Sub Class_Initialize()

Const FUNCTION_NAME = "Class_Initialize"
Const MAX_PATH = 260

Dim sFolder As String   ' Name of the folder
Dim lRet As Long        ' Return Value

'------------------------

m_strSubFolder = ""

' Get Windows' temp. folder
m_strWinTempFolder = ""
sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)
If lRet <> 0 Then
    m_strWinTempFolder = Left(sFolder, InStr(sFolder, Chr(0)) - 1)
Else
    RaiseProjectError ERR_WRONG_PATH, typeName(Me), FUNCTION_NAME, "Error getting Windows temp. folder."
End If

Set fso = New Scripting.FileSystemObject

End Sub

Private Sub Class_Terminate()

RemoveSubfolder
Set fso = Nothing

End Sub

Public Property Get subFolder() As String

subFolder = m_strSubFolder

End Property

''
' Create sub folder in Win temp folder
'
' @param    strsubFolder   New folder name
'
Public Property Let subFolder(ByVal strSubFolder As String)

Const FUNCTION_NAME = "subFolder"

Dim aFolders() As String
Dim strTempFolder As String
Dim s As String
Dim i As Integer
Dim es As tSavedError

'------------------------

On Error GoTo Catch

' If folder already exists, raise error
If fso.FolderExists(fullPath(strSubFolder)) Then RaiseProjectError ERR_PATH_EXISTS, , , "This temp path already exists!"

' If folder has been already specified, deny any change
If m_strSubFolder <> "" Then err.Raise 75, , "Class doesn't allow re-defintion of temp folder!"

' Create new temp folder(s)
s = strSubFolder
If Left(s, 1) <> "\" Then s = "\" & s
If Right(s, 1) <> "\" Then s = s & "\"
aFolders = Split(s, "\")
strTempFolder = m_strWinTempFolder
For i = 1 To UBound(aFolders) - 1
    strTempFolder = BuildPath(strTempFolder, aFolders(i))
    fso.CreateFolder strTempFolder
Next i
m_strSubFolder = strSubFolder

'------------------------
Final:
On Error GoTo 0
RaiseSavedError es
Exit Property

'------------------------
Catch:
es = SaveError(typeName(Me), FUNCTION_NAME, Erl)
Select Case es.Number
    Case GetVBErrorNumber(ERR_PATH_EXISTS)
        es.Helpfile = App.Helpfile
        es.HelpContext = 3
        es.Description = es.Description & vbNewLine & "Please see the help file for detailed information about this problem!"
        
    Case Else
        Debug.Print es.Number, es.Source, es.Description
End Select
Resume Final
Resume ' for test purposes only


End Property

''
' Remove folder recursively
'
Private Sub RemoveSubfolder()

Const FUNCTION_NAME = "RemoveSubfolder"

Dim es As tSavedError

'------------------------

On Error GoTo Catch

If m_strSubFolder <> "" Then
    fso.DeleteFolder fullPath()
    m_strSubFolder = ""
End If

'------------------------
Final:
On Error GoTo 0
RaiseSavedError es
Exit Sub

'------------------------
Catch:
es = SaveError(typeName(Me), FUNCTION_NAME, Erl)
Select Case es.Number
    Case Else
        Debug.Print es.Number, es.Source, es.Description
End Select
Resume Final
Resume ' for test purposes only

End Sub

Public Property Get getWinTempFolder() As String

getWinTempFolder = m_strWinTempFolder

End Property

Private Function fullPath(Optional ByVal f As String = "") As String

Const FUNCTION_NAME = "fullPath"

Dim sResult As String

'------------------------

sResult = ""

If f = "" Then f = m_strSubFolder
If f <> "" Then
    sResult = fso.BuildPath(m_strWinTempFolder, f)
Else
    RaiseProjectError ERR_WRONG_PATH, typeName(Me), FUNCTION_NAME, "Full path cannot be determined."
End If

fullPath = sResult

End Function