Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hWnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long
Public Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Public Const CSIDL_LOCAL_APPDATA = &H1C
Public Const MAX_PATH = 260
Public Const NOERROR = 0
Public Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String
strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function
Function GetLocalSettingsDirectory() As String
'Closest thing is to get APPDATA and then strip off "Application Data"
Dim strLocalSettings As String
strLocalSettings = SpecFolder(CSIDL_LOCAL_APPDATA)
strLocalSettings = StrReverse(strLocalSettings)
strLocalSettings = Mid(strLocalSettings, InStr(strLocalSettings, "\"))
strLocalSettings = StrReverse(strLocalSettings)
GetLocalSettingsDirectory = strLocalSettings
End Function
Function FileLocation(ByVal IsEmailed As Boolean, ByVal strFileName As String) As String
Dim strConstantDirectory, strNonEmailedDirectory
strConstantDirectory = "STATS\2006\P10\" 'No leading "\", but insert the trailing "\"
strNonEmailedDirectory = "W:\Operations\Manufacturing\" & strConstantDirectory
If (IsEmailed) Then
FileLocation = GetLocalSettingsDirectory & strConstantDirectory & strFileName
Else
FileLocation = strNonEmailedDirectory & strFileName
End If
End Function
Sub ChangeHyperlink(ByVal rngRange As Range, ByVal strLink As String)
rngRange.Hyperlinks.Delete
rngRange.Hyperlinks.Add rngRange, strLink
End Sub