Winapi 如何使用Vb6中的SHGetKnownFolderPath函数
我目前正在将Windows 7支持添加到现有的Vb6项目中,我遇到了使用SHGetFolderPath查找特殊文件夹路径的问题,而从Vista开始的Windows版本不支持SHGetFolderPath。我知道我应该使用SHGetKnownFolderPath,但我找不到一个在VB6中实现使用SHGetKnownFolderPath API调用的好例子。使用本文下面的代码 在模块WINAPI32.bas顶部声明API调用Winapi 如何使用Vb6中的SHGetKnownFolderPath函数,winapi,windows-7,vb6,known-folders,Winapi,Windows 7,Vb6,Known Folders,我目前正在将Windows 7支持添加到现有的Vb6项目中,我遇到了使用SHGetFolderPath查找特殊文件夹路径的问题,而从Vista开始的Windows版本不支持SHGetFolderPath。我知道我应该使用SHGetKnownFolderPath,但我找不到一个在VB6中实现使用SHGetKnownFolderPath API调用的好例子。使用本文下面的代码 在模块WINAPI32.bas顶部声明API调用 Private Declare Function SHGetSpecial
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
很好 更容易使用
建议延迟绑定,因为Microsoft没有注意与此对象的兼容性
Const ssfCOMMONAPPDATA = &H23
Const ssfLOCALAPPDATA = &H1c
Const ssfAPPDATA = &H1a
Dim strAppData As String
strAppData = _
CreateObject("Shell.Application").NameSpace(ssfAPPDATA).Self.Path
使用
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
迟来的答复。但它实际上展示了如何在x64 VBA中使用
SHGetKnownFolderPath
,并且没有避免这种情况的解决方法
我使用了这个德国来源:
这里给出的解决方案在x64 Office上不起作用。所以我改了。从VBA调用本机DLL需要
- 使用新关键字
李>PtrSafe
- 对所有指针使用
而不是LongPtr
李>Long
- 通过函数
将VBA字符串转换为StrPtr
对象李>LongPtr
- 调用DLL的Unicode版本,通常标记为“W”
在上面的链接中,您可以找到所有
FOLDERID_Blah
字符串。我终于找到了一个示例。与此问题类似,如果dwMajorVersion>6,则If将无法正常工作。您可以只测试osinfo.dwMajorVersion>=6,甚至不用担心dwPlatformId测试,因为Windows 9x在命名空间的dwMajorVersion=4.id值处停止
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