I am currently adding Windows 7 support to an existing Vb6 project and I have ran into a problem with locating special folder paths using SHGetFolderPath which is not supported on Windows versions starting with Vista. I know I should use SHGetKnownFolderPath but I cannot find a good example implementing using SHGetKnownFolderPath API call in VB6.
4 回答
Easier to use the Shell object Late binding is advised because Microsoft haven't been careful about compatibility with this object.
Const ssfCOMMONAPPDATA = &H23
Const ssfLOCALAPPDATA = &H1c
Const ssfAPPDATA = &H1a
Dim strAppData As String
strAppData = _
CreateObject("Shell.Application").NameSpace(ssfAPPDATA).Self.Path
使用本文下面的代码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
效果很好!
在 Vista 和 Win7 下使用SHGetFolderPath
from可以正常工作:shfolder.dll
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
一个很晚的答案。但它实际上展示了如何SHGetKnownFolderPath
在 x64 VBA 中使用,并且没有解决方法来避免它。
我使用了这个德国资源:https ://dbwiki.net/wiki/VBA_Tipp:_Spezielle_Verzeichnisse_ermitteln
那里给出的解决方案不适用于 x64 Office。所以我改变了它。从 VBA 调用本机 DLL 需要
- 新关键字的使用
PtrSafe
。 - 使用 of
LongPtr
而不是Long
所有指针。 LongPtr
通过函数将 VBA 字符串转换为对象StrPtr
。- 调用 DLL 的 Unicode 版本,通常标有“W”。</li>
代码:
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
字符串。