从 VBA 编写 xml

Question

我编写了一个 VBA 脚本，用于将 Excel 工作簿中的数据插入到 xml 文件中。 要编辑的 xml 文件是从文件对话框选择器中选择的：

Public strFile As String
    
Sub SetPath()

' Declare filedialog picker
Set fd = Application.FileDialog(msoFileDialogFilePicker)

' Define attributes for the filepicker to only allow a single xml file
With fd
    .Filters.Clear
    .Filters.Add "XML files", "*.xml", 1
    .Title = "Choose file"
    .AllowMultiSelect = False
    .InitialFileName = ActiveWorkbook.Path & "\"
    
    ' If a file is chosen save the path and name
    If .Show = True Then
    
        strFile = .SelectedItems(1)
    
    Else
        
        'MsgBox "Error"
    
    End If

End With

End Sub

之后我打开、编辑并保存文件：

Sub WriteXML()
   
Call SetPath

' Open the xml-file
Dim xmlFile As String
xmlFile = strFile
     
Set xmlWriter = CreateObject("Microsoft.XMLDOM")
xmlWriter.async = False
xmlWriter.Load xmlFile
    
' long codeblock for editing the file
    
xmlWriter.Save xmlFile
Set xmlWriter = Nothing
    
End Sub

该代码在我的私人计算机上运行良好，但是在我的公司 PC 上运行它时出现错误： “文件名目录名称或卷标语法不正确”

我怀疑它涉及我公司的电脑使用sharepoint从而制作保存路径：

'https://company-my.sharepoint.com/personal/mat_company_com/Documents/Desktop/myTemplates/Templates/file.xml'

反对： 'C:\Users\Mat\Documents ile.xml'

有什么办法可以解决这个问题吗？

Answer 1

假设您不需要 Mac 支持，这将显示如何将 HTTP 路径转换为本地路径，假设 SharePoint 源已同步到您的本地驱动器：

Sub Tester()

    Dim p As String
    
    p = ActiveWorkbook.Path
    
    If UCase(p) Like "HTTP*" Then p = GetLocalPath(p)
    
    Debug.Print "Local Path is:", vbLf, p

End Sub

'See: https://stackoverflow.com/a/67697487/478884
Public Function GetLocalPath(ByVal Path As String) As String
    Const HKCU = &H80000001
    Dim objReg As Object, rPath As String, subKeys(), subKey
    Dim urlNamespace As String, mountPoint As String, secPart As String
    
    Debug.Print "Checking for:" & vbLf & Path
    Debug.Print "--------------------"
    
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\." & _
                           "\root\default:StdRegProv")
    rPath = "Software\SyncEngines\Providers\OneDrive\"
    objReg.EnumKey HKCU, rPath, subKeys
    For Each subKey In subKeys
        
        objReg.GetStringValue HKCU, rPath & subKey, "UrlNamespace", urlNamespace
        Debug.Print urlNamespace
        
        If InStr(1, Path, urlNamespace, vbTextCompare) > 0 Then
            objReg.GetStringValue HKCU, rPath & subKey, "MountPoint", mountPoint
            secPart = Replace(Mid(Path, Len(urlNamespace)), "/", "\")
            Path = mountPoint & secPart
            Do Until Dir(Path, vbDirectory) <> "" Or InStr(2, secPart, "\") = 0
                secPart = Mid(secPart, InStr(2, secPart, "\"))
                Path = mountPoint & secPart
            Loop
            Exit For
        End If
    Next
    GetLocalPath = Path
End Function