VBA

Question

这是我第一次就堆栈溢出寻求任何帮助，更不用说评论了，所以请对我温柔点:)

我对这个一头雾水，我会尽可能提供更多信息。

问题

我想先说明一下，此代码不会导致 0365 的最新更新出现任何崩溃，只会导致版本 1807 及更早版本崩溃。它也根本不会在 32 位版本上崩溃，这让我认为这是一个 64 位问题。我的客户也不能从这个版本更新，所以简单地要求他们更新是不可能发生的。

我已将崩溃范围缩小到这个特定部分。

Public Function GetSpecialFolder(CSIDL As Long) As String
'*******************************************************************************
'*  Function:     GetSpecialFolder
'*  Purpose:      Wraps the apis to retrieve folders such as My Docs etc.

'*******************************************************************************
      Dim idlstr                   As Long
      Dim sPath                         As String
      Dim IDL                           As ITEMIDLIST
      Const MAX_LENGTH = 260

      'Fill the IDL structure with the specified folder item.
      On Error GoTo GetSpecialFolder_Error

      idlstr = SHGetSpecialFolderLocation _
          (0, CSIDL, IDL)

      If idlstr = 0 Then
        'Get the path from the IDL list, and return the folder adding final "\".
        sPath = Space$(MAX_LENGTH)
        **idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)**
        If idlstr Then
          GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) _
              - 1) & "\"
        End If
      End If

    procExit:
      On Error Resume Next
      Exit Function

    GetSpecialFolder_Error:
      CommonErrorHandler lngErrNum:=Err.Number, strErrDesc:=Err.Description, _
        strProc:="GetSpecialFolder", strModule:="modWinAPI", lngLineNum:=Erl
      Resume procExit

    End Function

这是声明

'File system
Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare PtrSafe Function GetTempPath Lib "kernel32" _
    Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As LongPtr

Private Type ITEMIDLIST
mkid                              As ShortItemId
End Type

Private Type ShortItemId
  cb                                As Long
  abID                              As Byte
End Type

我尝试按照我在网上找到的文档中的建议添加 LongPtr，但没有帮助。

谁能帮帮我？

谢谢！

Answer 1

SHGetSpecialFolderLocation 不会像 Declared 函数通常那样填充您为 ITEMIDLIST 分配的内存，它会分配一块您稍后 required 的新内存] 用 CoTaskMemFree 免费。这使得将 ITEMIDLIST 声明为 VBA 中的结构毫无意义（并且您的声明无论如何都是错误的，cb 必须是 Integer，并且 abID是变长字节数组，不是单个字节）。

如果您需要对以这种方式分配的结构的各个成员执行某些操作，则必须使用 CopyMemory 从 returned 指针中复制它们。幸运的是，您不需要执行任何操作，因为 SHGetSpecialFolderLocation return 是指向 PIDLIST_ABSOLUTE 的指针，并且 SHGetPathFromIDList accepts PCIDLIST_ABSOLUTE:

Public Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As LongPtr, ByVal nFolder As Long, ByRef pIdl As LongPtr) As Long

Public Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pIdl As LongPtr, ByVal pszPath As String) As Long

Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (pv As Any)

Public Function GetSpecialFolder(ByVal CSIDL As Long) As String
  Dim retval As Long
  Dim pIdl As LongPtr
  Dim sPath As String

  Const MAX_LENGTH = 260


  retval = SHGetSpecialFolderLocation(0, CSIDL, pIdl)

  If retval = 0 Then
    sPath = Space$(MAX_LENGTH)
    retval = SHGetPathFromIDList(pIdl, sPath)

    If retval <> 0 Then
      GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) & "\"
    End If

    CoTaskMemFree ByVal pIdl
  End If

End Function

请注意，在此类函数中使用 On Error Goto 是没有意义的，因为 Windows API 通常不会引发异常，它们会 return 错误代码。如果您在发现 return 值表示错误后使用 Err.Raise ...，会有意义。

Answer 2

TBH，我不知道这是如何在 32 位版本上正常运行的。这两个结构的声明不正确。这个...

Private Type ShortItemId
  cb                                As Long
  abID                              As Byte
End Type

...在 the MS documentation 中定义为：

typedef struct _SHITEMID {
  USHORT cb;
  BYTE   abID[1];
} SHITEMID;

注意 abID 是一个数组，cb 是一个无符号短整数（你可以在 VBA 中使用 Integer，但它绝对不是Long).

此外，这个结构（包裹在 ITEMIDLIST 中）甚至不应该由调用者分配 , 但必须由调用者释放:

It is the responsibility of the calling application to free the returned IDList by using CoTaskMemFree.

关于指针，唯一的指针（未从 String 编组）是 pidl SHGetSpecialFolderLocation and the pointer to ppidl in SHGetPathFromIDList 的参数。请注意，您不能使用 VBA 定义的结构，因为您需要在完成后释放内存。这样的事情会起作用：

Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As LongPtr) As Long

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr)

Private Const S_OK As Long = 0
Private Const MAX_LENGTH = 260

Public Function GetSpecialFolder(ByVal CSIDL As Integer) As String
    Dim result As Long
    Dim path As String
    Dim idl_ptr As LongPtr

    'Fill the IDL structure with the specified folder item.
    result = SHGetSpecialFolderLocation(0, CSIDL, idl_ptr)

    If result = S_OK Then
        'Get the path from the IDL list, and return the folder adding final "\".
        path = Space$(MAX_LENGTH)
        If SHGetPathFromIDList(idl_ptr, path) Then
            GetSpecialFolder = Left$(path, InStr(path, vbNullChar) - 1) & "\"
        End If
        CoTaskMemFree idl_ptr
    End If
End Function

请注意，根据评论中的讨论，您也可以在技术上将 hwndOwner 声明为 LongPtr，但这应该没有任何区别。

VBA - Office 365 x64 位 - 完全崩溃

VBA - Office 365 x64 bit - Completely crashing

ms-office