如何使用 Vb6 中的 SHGetKnownFolderPath 函数

Question

我目前正在向现有的 Vb6 项目添加 Windows 7 支持，但我遇到了使用 SHGetFolderPath 定位特殊文件夹路径的问题，从 Vista 开始的 Windows 版本不支持该路径。 我知道我应该使用 SHGetKnownFolderPath 但我找不到在 VB6 中使用 SHGetKnownFolderPath API 调用实现的好例子。

Answer 1

建议更容易使用Shell 对象后期绑定，因为 Microsoft 没有注意与此对象的兼容性。

Const ssfCOMMONAPPDATA = &H23 
Const ssfLOCALAPPDATA = &H1c
Const ssfAPPDATA = &H1a
Dim strAppData As String 

strAppData = _ 
    CreateObject("Shell.Application").NameSpace(ssfAPPDATA).Self.Path 

Answer 2

使用下面这篇文章的代码vba/vb6在模块 WINAPI32.bas 的顶部声明 API 调用

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
                    (ByVal hwndOwner As Long, ByVal nFolder As Long, _
                     pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                        (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type

添加了一个新的公共功能：

Public Function SHGetSpecialFolderLocationVB(ByVal lFolder As Long) As String
    Dim lRet As Long, IDL As ITEMIDLIST, sPath As String

    lRet = SHGetSpecialFolderLocation(100&, lFolder, IDL)
    If lRet = 0 Then
        sPath = String$(512, chr$(0))
        lRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
        SHGetSpecialFolderLocationVB = Left$(sPath, InStr(sPath, chr$(0)) - 1)
    Else
        SHGetSpecialFolderLocationVB = vbNullString
    End If
End Function

添加了检查 Windows Vista 或更高版本的新功能

Public Function IsVistaOrHigher() As Boolean
    Dim osinfo As OSVERSIONINFO
    Dim retvalue As Integer
    Dim bVista As Boolean

    bVista = False

    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    retvalue = GetVersionExA(osinfo)

    If osinfo.dwPlatformId = 2 Then
        If osinfo.dwMajorVersion >= 6 Then
            bVista = True
        End If
    End If
    IsVistaOrHigher = bVista
End Function

改变了之前调用 SHGetFolderPath 的方法

Public Function SHGetFolderPathVB(ByVal lFolder As Long) As String
    Dim path As String
    If IsVistaOrHigher() Then
        SHGetFolderPathVB = SHGetSpecialFolderLocationVB(lFolder)
    Else
        path = Space$(MAX_PATH)
        SHGetFolderPath 0, lFolder, 0, SHGFP_TYPE_CURRENT, path
        SHGetFolderPathVB = Left(path, InStr(path, vbNullChar) - 1)
    End If
End Function

效果很好！

Answer 3

使用shfolder.dll SHGetFolderPath在 Vista 和 Win7 下工作正常：

Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" (ByVal hWnd As Long, ByVal csidl As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal szPath As String) As Long

然后在这些CSIDL_Xxx常量上声明一个枚举：

Public Function GetSpecialFolder(ByVal eType As MySpecialFolderType) As String
    GetSpecialFolder = String(1000, 0)
    Call SHGetFolderPath(0, eType, 0, 0, GetSpecialFolder)
    GetSpecialFolder = Left$(GetSpecialFolder, InStr(GetSpecialFolder, Chr$(0)) - 1)
End Function

Answer 4

一个很晚的答案。 但它实际上展示了如何在 x64 VBA 中使用SHGetKnownFolderPath并且没有解决方法来避免它。

我使用了这个德国来源： https : //dbwiki.net/wiki/VBA_Tipp : _Spezielle_Verzeichnisse_ermitteln

那里给出的解决方案不适用于 x64 Office。 所以我改变了它。 从 VBA 调用本机 DLL 需要

• 新关键字PtrSafe 。
• 对所有指针使用LongPtr而不是Long 。
• 通过函数StrPtr将 VBA 字符串转换为LongPtr对象。
• 调用 DLL 的 Unicode 版本，通常标有“W”。

代码：

Public Const FOLDERID_ProgramFiles1  As String = "{905E63B6-C1BF-494E-B29C-65B732D3D21A}"

Public Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(7) As Byte
End Type

Public Const S_OK As Long = 0
Public Const WIN32_NULL As Long = 0

Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal hMem As LongPtr)

Public Declare PtrSafe Function CLSIDFromString Lib "ole32" ( _
  ByVal lpszGuid As LongPtr, _
  ByRef pGuid As GUID) As Long

Public Declare PtrSafe Function lstrlenW Lib "kernel32" ( _
 ByVal lpString As LongPtr) As Long

Public Declare PtrSafe Function SHGetKnownFolderPath Lib "shell32" ( _
  ByRef rfid As GUID, _
  ByVal dwFlags As Long, _
  ByVal hToken As Long, _
  ByRef pszPath As LongPtr) As Long

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
 ByVal Destination As LongPtr, _
 ByVal Source As LongPtr, _
 ByVal length As Long)

Public Function GetBstrFromWideStringPtr(ByVal lpwString As LongPtr) As String
  Dim length As Long

  If (lpwString) Then length = lstrlenW(lpwString)
  If (length) Then
    GetBstrFromWideStringPtr = Space$(length)
    CopyMemory StrPtr(GetBstrFromWideStringPtr), lpwString, length * 2
  End If
End Function

Public Function GetKnownFolder(ByVal KnownFolderID As String) As String
'Returns empty String on any error.
  Dim ref As GUID
  Dim pszPath As LongPtr

  If (CLSIDFromString(StrPtr(KnownFolderID), ref) = S_OK) Then
    If (SHGetKnownFolderPath(ref, 0, WIN32_NULL, pszPath) = S_OK) Then
      GetKnownFolder = GetBstrFromWideStringPtr(pszPath)
      CoTaskMemFree pszPath
    End If
  End If
End Function

Sub TestKnownFolder()
 MsgBox GetKnownFolder(FOLDERID_ProgramFiles1)
End Sub

在上面的链接中，您可以找到所有FOLDERID_Blah字符串。