Question

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

Answer 1

更容易使用Shell object 建议使用延迟绑定，因为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

使用SHGetFolderPath中的shfolder.dll在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中使用MainActivity，并且没有避免该问题的解决方法。

我使用了以下德语来源：https://dbwiki.net/wiki/VBA_Tipp:_Spezielle_Verzeichnisse_ermitteln

给出的解决方案在x64 Office上不起作用。所以我改变了。从VBA调用本机DLL需要

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

代码：

StrPtr

在上面的链接中，您可以找到所有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字符串。

如何使用Vb6中的SHGetKnownFolderPath函数

4 个答案: