使用VBA 7.1获取希伯来语文件夹路径乱码问题求助

核心问题 #

VBA默认采用ANSI编码处理字符串，当路径包含非系统默认编码的字符（如希伯来语）时，会出现乱码（显示为???）。仅修改区域设置无法解决跨软件（SOLIDWORKS/Excel等）的通用场景，需从路径获取和编码处理两方面入手。

解决方法 #

1. 使用Unicode兼容的文件对话框获取路径 #

默认的VBA文件对话框（如Application.GetSaveAsFilename）不支持Unicode，需调用Windows API的Unicode版本函数来获取正确的希伯来语路径。以下是适配SOLIDWORKS宏的示例：

Option Explicit

' 声明Unicode版本的文件夹选择API
Private Declare PtrSafe Function SHBrowseForFolderW Lib "shell32.dll" (lpBrowseInfo As BROWSEINFOW) As LongPtr
Private Declare PtrSafe Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal pidl As LongPtr, ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr) As Long

Private Type BROWSEINFOW
    hOwner As LongPtr
    pidlRoot As LongPtr
    pszDisplayName As LongPtr
    lpszTitle As LongPtr
    ulFlags As Long
    lpfn As LongPtr
    lParam As LongPtr
    iImage As Long
End Type

Dim swApp As Object
Dim Part As Object
Dim longstatus As Long, longwarnings As Long

Sub main()
    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
    
    ' 获取Unicode格式的文件夹路径
    Dim folderPath As String
    folderPath = GetUnicodeFolderPath("选择保存文件夹")
    
    If folderPath <> "" Then
        ' 拼接完整保存路径（包含希伯来语文件夹）
        Dim fullPath As String
        fullPath = folderPath & "\models\FH-02-003.SLDASM"
        ' 调用SaveAs3保存，直接传入Unicode字符串
        longstatus = Part.SaveAs3(fullPath, 0, 0)
    End If
End Sub

' 获取Unicode文件夹路径的函数
Private Function GetUnicodeFolderPath(title As String) As String
    Dim bi As BROWSEINFOW
    Dim pidl As LongPtr
    Dim pathBuffer As String
    Dim bufferSize As Long
    
    bi.lpszTitle = StrPtr(title)
    bi.ulFlags = &H1 ' 返回文件夹路径而非PIDL
    
    pidl = SHBrowseForFolderW(bi)
    
    If pidl <> 0 Then
        ' 获取路径长度
        bufferSize = lstrlenW(pidl) * 2 + 2
        pathBuffer = String$(bufferSize, vbNullChar)
        ' 转换为字符串
        SHGetPathFromIDListW pidl, StrPtr(pathBuffer)
        ' 去除末尾空字符
        GetUnicodeFolderPath = Left$(pathBuffer, InStr(pathBuffer, vbNullChar) - 1)
        ' 释放内存
        CoTaskMemFree pidl
    End If
End Function

2. 字符串编码转换（ANSI转UTF-8/Unicode） #

如果已获取到乱码的ANSI字符串，可通过ADODB.Stream将其转换为Unicode（UTF-16）或UTF-8格式：

Function AnsiToUnicode(ansiStr As String) As String
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    
    stream.Charset = "windows-1255" ' 希伯来语对应的ANSI编码页
    stream.Open
    stream.WriteText ansiStr
    stream.Position = 0
    stream.Charset = "utf-16" ' 转换为Unicode
    AnsiToUnicode = stream.ReadText
    stream.Close
End Function

Function AnsiToUtf8(ansiStr As String) As String
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    
    stream.Charset = "windows-1255"
    stream.Open
    stream.WriteText ansiStr
    stream.Position = 0
    stream.Charset = "utf-8"
    AnsiToUtf8 = stream.ReadText
    stream.Close
End Function

注意事项 #

• SOLIDWORKS的SaveAs3方法支持Unicode路径，只要传入的字符串是正确的Unicode格式即可。
• Excel等其他Office软件的文件操作API（如SaveAs）同样需要使用Unicode兼容的方式调用，避免默认ANSI编码导致的乱码。

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