VB6 Vista UAC Problem

[Merri]

I couldn't get sleep so I coded this while trying to make myself more tired:

' goes into a module
Option Explicit

Public Enum SystemPathType
    [Type Current] = &H0&
    [Type Default] = &H1&
End Enum

Public Enum SystemPathVariable
    [Path Desktop] = &H0&
    [Path Internet]
    [Path Programs]
    [Path Controls]
    [Path Printers]
    [Path Personal]
    [Path Favorites]
    [Path Startup]
    [Path Recent]
    [Path SendTo]
    [Path BitBucket]
    [Path StartMenu]
    [Path My Documents]
    [Path My Music]
    [Path My Video]
    [Path Desktop Directory] = &H10&
    [Path Drives]
    [Path Network]
    [Path Network Neighborhood]
    [Path Fonts]
    [Path Templates]
    [Path StartMenu All Users]
    [Path Programs All Users]
    [Path StartUp All Users]
    [Path Desktop Directory All Users]
    [Path AppData]
    [Path Printers Neighborhood]
    [Path AppData Current User]
    [Path StartUp Alternative]
    [Path StartUp Alternative All Users]
    [Path Favorites All Users]
    [Path Internet Cache]
    [Path Cookies]
    [Path History]
    [Path AppData All Users]
    [Path Windows]
    [Path System]
    [Path Program Files]
    [Path My Pictures]
    [Path Profile]
    [Path System X86]
    [Path Program Files X86]
    [Path Program Files All Users]
    [Path Program Files X86 All Users]
    [Path Templates All Users]
    [Path Documents All Users]
    [Path AdminTools All Users]
    [Path AdminTools]
    [Path Connections]
    [Path Music All Users] = &H35&
    [Path Pictures All Users]
    [Path Video All Users]
    [Path Resources]
    [Path Resources Localized]
    [Path OEM Links All Users]
    [Path CD Burn Area]
    [Path Computers Near Me] = &H3D&
End Enum

Private Const CSIDL_FLAG_PER_USER_INIT = &H800&
Private Const CSIDL_FLAG_NO_ALIAS = &H1000&
Private Const CSIDL_FLAG_DONT_VERIFY = &H4000&
Private Const CSIDL_FLAG_CREATE = &H8000&
Private Const CSIDL_FLAG_MASK = &HFF00&

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function SHGetFolderPathShell32 Lib "shell32.dll" Alias "SHGetFolderPathW" (ByVal hWndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwReserved As Long, ByVal lpszPath As Long) As Long
Private Declare Function SHGetFolderPathSHFolder Lib "shfolder.dll" Alias "SHGetFolderPathW" (ByVal hWndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwReserved As Long, ByVal lpszPath As Long) As Long

Public Function GetSystemPath(ByVal SystemPath As SystemPathVariable, Optional ByVal PathType As SystemPathType, Optional ByVal CreateIfNotExists As Boolean = True, Optional ByVal hWndDialUpParent As Long, Optional ByVal UserToken As Long) As String
    Static blnChecked As Boolean, blnShell32 As Boolean, blnSHFolder As Boolean, blnSpecialFolder As Boolean
    Dim bytPath(513) As Byte, lngPos As Long, lngFlags As Long
    ' small speed optimization: no need to check for function being supported every time we run this
    If blnChecked Then
    Else
        ' check for supported functions
        blnShell32 = IsFunctionSupported("SHGetFolderPathW", "shell32")
        If Not blnShell32 Then
            blnSHFolder = IsFunctionSupported("SHGetFolderPathW", "shfolder")
            If Not blnSHFolder Then
                ' drop back as far as to GetSpecialFolderPath?
                blnSpecialFolder = IsFunctionSupported("SHGetSpecialFolderPathW", "shell32")
            End If
        End If
        ' mark we have done this
        blnChecked = True
    End If
    ' see if the path will be created if it is missing
    If CreateIfNotExists Then lngFlags = SystemPath Or CSIDL_FLAG_CREATE Else lngFlags = SystemPath
    ' support for this started from Windows 2000 and Windows ME, but may also be supported on older systems via shell32
    If blnShell32 Then
        ' attempt to get the path
        If SHGetFolderPathShell32(hWndDialUpParent, lngFlags, UserToken, CLng(PathType), VarPtr(bytPath(0))) = 0& Then
            ' get string length
            lngPos = InStr(bytPath, vbNullChar)
            ' get the path if has some length
            If lngPos > 1 Then GetSystemPath = Left$(bytPath, lngPos - 1)
        End If
    ElseIf blnSHFolder Then
        ' attempt to get the path
        If SHGetFolderPathSHFolder(hWndDialUpParent, lngFlags, UserToken, CLng(PathType), VarPtr(bytPath(0))) = 0& Then
            ' get string length
            lngPos = InStr(bytPath, vbNullChar)
            ' get the path if has some length
            If lngPos > 1 Then GetSystemPath = Left$(bytPath, lngPos - 1)
        End If
    'ElseIf blnSpecialFolder Then
    ' ... in case somebody really thinks he needs to support this ...
    Else
    ' YOU MUST MAKE SURE THAT YOU ACTUALLY GET A FOLDER FROM THIS FUNCTION
    ' IF STRING IS EMPTY, TRY ANOTHER PATH, IF STILL FAILS, YOU ARE AT CRITICAL ERROR
    End If
End Function
Private Function IsFunctionSupported(ByRef FunctionName As String, ByRef ModuleName As String) As Boolean
    Dim lngModule As Long, blnUnload As Boolean
    ' get handle to module
    lngModule = GetModuleHandleA(ModuleName)
    ' if getting the handle failed...
    If lngModule = 0 Then
        ' try loading the module
        lngModule = LoadLibraryA(ModuleName)
        ' we have to unload it too if that succeeded
        blnUnload = (lngModule <> 0)
    End If
    ' now if we have a handle to module...
    If lngModule <> 0 Then
        ' see if the queried function is supported; return True if so, False if not
        IsFunctionSupported = (GetProcAddress(lngModule, FunctionName) <> 0)
        ' see if we have to unload the module
        If blnUnload Then FreeLibrary lngModule
    End If
End Function

And a short test program, requires a list box:

Option Explicit

Private Sub Form_Load()
    Dim lngA As Long, strPath As String
    For lngA = 0 To [Path Computers Near Me]
        strPath = GetSystemPath(lngA)
        If LenB(strPath) Then List1.AddItem Right$("0" & Hex$(lngA), 2) & vbTab & strPath
    Next lngA
    List1.ListIndex = 0
End Sub

What I've fixed here are:

• Complete error detection.
• Enums being used for greatly helping with the usage of the function.
• Unicode support: these paths can be configured to Unicode paths. Unlikely, but it can be done.
• Ability to select any folder of interest. It is up to the function user to check whether they actually got a result or not. Ie. if they don't get a folder for any Application Data results, they can assume an older Windows and manually create C:\Windows\Application Data\.
• Ability to get any user's (shared) folders (by passing the token value).
• Ability to get the default location vs. user's current location.
• And do all this without modifying the function.

[chip!]

Merri,

I have tested your code but I was unable to get the Unicode paths to work and I was wondering if you might have any insight to the situation.

For testing purposes, I have created a user account with a Japanese character in its name (using Windows Character Map). My Vista system is default en-us charset.

When I log into this account and call GetSystemPath([Path AppData]), the return is:

"C:\Users\?\AppData\Roaming"

So, I am assuming there is something wrong, because I can not work with this path. For ex,

dim sPath as string
sPath = GetSystemPath([Path AppData])
mkdir sPath & "\test"

The "test" directory was not created. I also tried several other tests directly using sPath.

Ultimately, I would like to be able to call GetShortPathName() on the sPath to make it VB6 safe to call WritePrivateProfileString() so that I can read/write application data saved inside "User\AppData", even if there is Unicode characters in the Username.

Thanks,
-chip!