OneDrive环境下获取桌面路径报错：VBA代码运行出现类型不匹配

原代码的核心问题在于GUID结构赋值错误和指针类型不兼容，导致运行时触发类型不匹配异常。以下是修正后的完整代码及问题说明：

问题分析 #

1. GUID赋值逻辑错误：原代码直接将完整的GUID字符串转换为Long类型赋值给rfid.Data1，完全不符合GUID结构的字段规则——GUID的每个部分需要从字符串中拆分，分别转换为对应的数据类型（Long、Integer、Byte数组）。
2. 指针类型不兼容：在64位VBA环境下，pszPath作为内存指针变量，必须使用LongPtr类型而非Long，否则会因指针长度不匹配引发错误。
3. 字符串读取逻辑错误：原代码用StrConv(StrPtr(GlobalLock(pszPath)), vbUnicode)读取路径的方式逻辑颠倒，正确做法是直接读取指针指向的Unicode内存区域。

修正后的代码 #

Option Compare Database
Option Explicit

' 适配32/64位系统的API声明
#If VBA7 Then
    Private Declare PtrSafe Function SHGetKnownFolderPath Lib "shell32.dll" ( _
        ByRef rfid As GUID, _
        ByVal dwFlags As Long, _
        ByVal hToken As LongPtr, _
        ByRef pszPath As LongPtr) As Long
        
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" ( _
        ByVal hMem As LongPtr) As LongPtr
        
    Private Declare PtrSafe Function lstrlenW Lib "kernel32" ( _
        ByVal lpString As LongPtr) As Long
#Else
    Private Declare Function SHGetKnownFolderPath Lib "shell32.dll" ( _
        ByRef rfid As GUID, _
        ByVal dwFlags As Long, _
        ByVal hToken As Long, _
        ByRef pszPath As Long) As Long
        
    Private Declare Function GlobalFree Lib "kernel32" ( _
        ByVal hMem As Long) As Long
        
    Private Declare Function lstrlenW Lib "kernel32" ( _
        ByVal lpString As Long) As Long
#End If

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

' 桌面文件夹的GUID常量
Private Const FOLDERID_Desktop As String = "{B4BFCC3A-DB2C-424C-B029-7FE99A87C641}"
Private Const S_OK As Long = 0

Public Function GetDesktopPath() As String
    Dim rfid As GUID
    Dim pszPath As LongPtr
    Dim ret As Long
    Dim pathLength As Long
    
    ' 解析GUID字符串到GUID结构
    ParseGUID FOLDERID_Desktop, rfid
    
    ' 调用API获取已知文件夹路径
    ret = SHGetKnownFolderPath(rfid, 0, 0, pszPath)
    
    If ret = S_OK Then
        ' 获取Unicode字符串长度并转换为VBA字符串
        pathLength = lstrlenW(pszPath)
        GetDesktopPath = String$(pathLength, vbNullChar)
        CopyMemory ByVal StrPtr(GetDesktopPath), ByVal pszPath, pathLength * 2
        
        ' 释放API分配的内存
        GlobalFree pszPath
    Else
        GetDesktopPath = ""
    End If
End Function

' 辅助函数：将字符串格式的GUID解析到GUID结构
Private Sub ParseGUID(ByVal guidStr As String, ByRef guid As GUID)
    Dim guidParts() As String
    Dim i As Integer
    
    ' 去除GUID字符串的大括号
    guidStr = Replace(Replace(guidStr, "{", ""), "}", "")
    guidParts = Split(guidStr, "-")
    
    ' 赋值各个字段
    guid.Data1 = CLng("&H" & guidParts(0))
    guid.Data2 = CInt("&H" & guidParts(1))
    guid.Data3 = CInt("&H" & guidParts(2))
    
    ' 解析Data4的16进制字节
    For i = 0 To 1
        guid.Data4(i) = CByte("&H" & Mid(guidParts(3), i * 2 + 1, 2))
    Next i
    For i = 0 To 5
        guid.Data4(i + 2) = CByte("&H" & Mid(guidParts(4), i * 2 + 1, 2))
    Next i
End Sub

' 内存复制函数声明
#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        ByVal Destination As LongPtr, _
        ByVal Source As LongPtr, _
        ByVal Length As Long)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        ByVal Destination As Long, _
        ByVal Source As Long, _
        ByVal Length As Long)
#End If

关键修改点说明 #

• 跨版本API适配：通过#If VBA7条件编译，同时兼容32位和64位VBA环境，确保指针类型（LongPtr）正确。
• GUID正确解析：新增ParseGUID辅助函数，将字符串格式的GUID拆分为各个字段并赋值到GUID结构中，这是解决类型不匹配的核心修复点。
• 规范内存管理：使用GlobalFree释放API分配的内存，避免内存泄漏；通过CopyMemory正确读取Unicode格式的路径字符串。
• 明确错误判断：使用S_OK常量判断API调用是否成功，返回空字符串表示获取失败。

内容的提问来源于stack exchange，提问作者plateriot