VBA Modules: modSpecialFolders v1.00a

Read this for full information on these modules

modSpecialFolders reports back the path for a variety of "special folders" from Windows Shell32.  It's fairly standard and extremely useful code, great for deducing where to save output files and such.

This code is copied from Microsoft support site, I've just added my own annotations.

'modSpecialFolders
'v1.00a 2013-07-19 11:55
'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\

'===========================================================================
' modSpecialFolders
'===========================================================================
'   Finds path to various "special folders" in Windows
'   e.g. My Documents, Program Files, Shared Documents, etc.

'===========================================================================
' Additional modules required:
'===========================================================================
'   None

'===========================================================================
' Additional References required:
'===========================================================================
'   None

'===========================================================================
' External applications required:
'===========================================================================
'   None

'=========================================================================
' VERSION HISTORY
'=========================================================================
'   v1.00a  annotations only
'   v1.00   created from source:
'           http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009



Option Explicit

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)

'Desktop
Public Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Public Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Public Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Public Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Public Const CSIDL_PERSONAL = &H5 'My Documents
Public Const CSIDL_FAVORITES = &H6 '\Favorites
Public Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Public Const CSIDL_RECENT = &H8 '\Recent
Public Const CSIDL_SENDTO = &H9 '\SendTo
Public Const CSIDL_BITBUCKET = &HA '\Recycle Bin
Public Const CSIDL_STARTMENU = &HB '\Start Menu
Public Const CSIDL_DESKTOPDIRECTORY = &H10 '\Desktop
Public Const CSIDL_DRIVES = &H11 'My Computer
Public Const CSIDL_NETWORK = &H12 'Network Neighborhood
Public Const CSIDL_NETHOOD = &H13 '\nethood
Public Const CSIDL_FONTS = &H14 'Windows\fonts
Public Const CSIDL_TEMPLATES = &H15
Public Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Public Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Public Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Public Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Public Const CSIDL_APPDATA = &H1A '\Application Data
Public Const CSIDL_PRINTHOOD = &H1B '\PrintHood
Public Const CSIDL_LOCAL_APPDATA = &H1C '\Local Settings\Application Data (non roaming)
Public Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Public Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Public Const CSIDL_COMMON_FAVORITES = &H1F
Public Const CSIDL_INTERNET_CACHE = &H20
Public Const CSIDL_COOKIES = &H21
Public Const CSIDL_HISTORY = &H22
Public Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Public Const CSIDL_WINDOWS = &H24 'Windows Directory
Public Const CSIDL_SYSTEM = &H25 'System Directory
Public Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Public Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Public Const CSIDL_PROFILE = &H28 'USERPROFILE
Public Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Public Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Public Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Public Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Public Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Public Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Public Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Public Const CSIDL_ADMINTOOLS = &H30 '\Start Menu\Programs\Administrative Tools
Public Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
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

VBA Macro to remove special characters from path and/or filename and/or VBA object name

Solution originally posted here:
http://stackoverflow.com/a/14157011/1540567 

This VBA function removes special characters from a string.  In my case I wanted a single function to return a valid path and/or filename and/or VBAProject name.  It works with both URL and UNC paths (and tries to clean up any paths with mixed slashes).

It's easy enough to tweak this for other purposes.  You can specify additional "forbidden" characters easily and add any extra boolean switches for your own specific needs, or you could just split into separate functions.

The function also checks the maximum string length and either crops or pops up a message box if a filename (not path) exceeds 128 characters -- very useful for SharePoint uploads -- or a VBA object name exceeds 35 characters.

Function fn_Clean_Special(str As String, CropLength As Boolean _
    , Optional VBObjectName As Boolean) As String
'v1.03 2013-01-04 15:54
'removes invalid special characters from path/file string
', True stops message box warnings and autocrops string
'     [, True] also removes spaces and hyphens and periods (VBA object)
'~ " # % & * : < > ? { | } ..   / \   -

Dim b As Integer, c As Integer, pp As String
Const tt As String = "fn_Clean_Special"
Dim sc(0 To 18) As String
sc(0) = "~"
sc(1) = Chr(34)  ' Chr(34) = " quotemark
sc(2) = "#"
sc(3) = "%"
sc(4) = "&"
sc(5) = "*"
sc(6) = ":"
sc(7) = "<"
sc(8) = ">"
sc(9) = "?"
sc(10) = "{"
sc(11) = "|"
sc(12) = "}"
sc(13) = ".."
'slashes for filenames and VB Object names
sc(14) = "/"
sc(15) = "\"
'hyphen & space & period for VB Object names
sc(16) = "-"
sc(17) = " "
sc(18) = "."

'remove special characters from all
For b = 0 To 13
    str = Replace(str, sc(b), vbNullString)
Next b

'check filename length (length AFTER the LAST slash max 128 chars)
b = InStr(1, str, sc(14))  'look for fwd slash
If b > 0 Then
    str = Replace(str, sc(15), sc(14))  'remove all back slashes
    Do Until b = 0  'until last slash found
        c = b       'c is position of last slash
        b = b + 1                   'next position
        b = InStr(b, str, sc(14))   'next position
    Loop
Else  'no fwd slashes
    b = InStr(1, str, sc(15))  'look for back slash
    If b > 0 Then
        str = Replace(str, sc(14), sc(15))  'remove all fwd slashes
        Do Until b = 0  'until last slash found
            c = b       'c is position of last slash
            b = b + 1                   'next position
            b = InStr(b, str, sc(15))   'next position
        Loop
    End If
End If
'c is position of last slash, or 0 if no slashes
If Len(str) - c > 128 Then
    If CropLength = True Then
        str = Left(str, 35)
    Else
        pp = "WARNING: filename > 128 chars"
        MsgBox pp, vbCritical, tt
    End If
End If

'remove slashes from filenames only
If c > 0 Then
    For b = 14 To 15
        str = Left(str, c) & Replace(Right(str, Len(str) - c), sc(b), vbNullString)
    Next b
End If


If VBObjectName = True Then
'remove slashes and swap hyphens & spaces & periods for underscore in VB object name
    Const scUS As String = "_"
    For b = 14 To 18
        str = Replace(str, sc(b), scUS)
    Next b
'then remove invalid characters from start of string
    Dim c1 As String
    c1 = Left(str, 1)
    Do While c1 = scUS Or c1 = sc(18) Or IsNumeric(c1)
        str = Right(str, Len(str) - 1)
        c1 = Left(str, 1)
    Loop
'remove double underscore
    Do While InStr(str, scUS & scUS) > 0
        str = Replace(str, scUS & scUS, scUS)
    Loop
    'check object name length (max 35 chars)
    If Len(str) > 35 Then
        If CropLength = True Then
            str = Left(str, 35)
        Else
            pp = "WARNING: object name > 35 chars"
            MsgBox pp, vbCritical, tt
        End If
    End If
End If

fn_Clean_Special = str

End Function

Debug Window results:

?fn_clean_special("\\server\path\filename.xls", True)
\\server\path\filename.xls
   
?fn_clean_special("\\server\path\filename.xls", True, True)
server_path_filename_xls

?fn_Clean_Special("\\special character\testing   for \VBproject.xls", True, True)
special_character_testing_for_VBpro