Option Explicit
Option Base 0
#Const m_blnErrorHandlersOff_c = False
Public Sub TestResolveEnvironmentVariables()
Const strInpt_c As String = vbNewLine & vbNewLine & vbTab & "Input:" & _
vbNewLine & vbTab & vbTab
Const strOtpt_c As String = vbNewLine & vbTab & "Output:" & vbNewLine & _
vbTab & vbTab
Const strTtlM_c As String = "ResolveEnvironmentVariables Procedure " & _
"Demonstration"
Const strTtl1_c As String = "Demonstrate normal resolution:" & strInpt_c
Const strTtl2_c As String = "Demonstrate default behavior for not " & _
"found variables:" & strInpt_c
Const strTtl3_c As String = "Demonstrate alternate behavior for not " & _
"found variables:" & strInpt_c
Dim strInpt As String
Dim strOtpt As String
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
#End If
strInpt = "%USERPROFILE%\%COMPUTERNAME%\Tada.yay"
strOtpt = ResolveEnvironmentVariables(strInpt)
MsgBox strTtl1_c & strInpt & strOtpt_c & strOtpt, vbInformation, strTtlM_c
strInpt = "%USERPROFILE%\%Foo%\Tada.yay"
strOtpt = ResolveEnvironmentVariables(strInpt)
MsgBox strTtl2_c & strInpt & strOtpt_c & strOtpt, vbInformation, strTtlM_c
strInpt = "%USERPROFILE%\%Foo%\Tada.yay"
strOtpt = ResolveEnvironmentVariables(strInpt, True)
MsgBox strTtl3_c & strInpt & strOtpt_c & strOtpt, vbInformation, strTtlM_c
Exit Sub
Err_Hnd:
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number
End Sub
Public Function ResolveEnvironmentVariables( _
ByVal value As String, _
Optional ByVal resolveEmpty As Boolean = False) As String
Const lngStep2_c As Long = 2
Const lngLwrBnd_c As Long = 1
Const strDlmtr_c As String = "%"
Dim strSgts() As String
Dim strVarVal As String
Dim strRtnVal As String
Dim lngIndx As Long
#If Not m_blnErrorHandlersOff_c Then
On Error GoTo Err_Hnd
#End If
strSgts = Split(value, strDlmtr_c)
For lngIndx = lngLwrBnd_c To UBound(strSgts) Step lngStep2_c
If LenB(strSgts(lngIndx)) Then
strVarVal = Environ$(strSgts(lngIndx))
If LenB(strVarVal) Then
strSgts(lngIndx) = strVarVal
ElseIf resolveEmpty Then
strSgts(lngIndx) = strVarVal
Else
strSgts(lngIndx) = strDlmtr_c & strSgts(lngIndx) & strDlmtr_c
End If
End If
Next
strRtnVal = Join(strSgts, vbNullString)
Exit_Proc:
On Error Resume Next
Erase strSgts
ResolveEnvironmentVariables = strRtnVal
Exit Function
Err_Hnd:
strRtnVal = value
MsgBox Err.Description, vbSystemModal, "Error: " & Err.Number
Resume Exit_Proc
End Function
|