从 onedrive VBA 上的工作表在同一文件夹上创建一个新工作簿

Question

我有如下代码。它正在复制工作表并将其另存为同一文件夹中的新工作簿，并打开活动工作簿。对话框打开，用户为此新工作簿键入新名称。但是，自从公司将文件夹移至 onedrive 后，它不再起作用了。

NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False

我有全名功能也可以将文件格式更改为 pdf 并且它正在工作。

 sPath = ActiveWorkbook.FullName
 FileName = LocalFullName(ActiveWorkbook.FullName)
 ActiveWorkbook.ExportAsFixedFormat _
   Type:=xlTypePDF, _
   FileName:=Left(FileName, InStr(FileName, ".") - 1), _
   Quality:=xlQualityStandard, _
   IncludeDocProperties:=True, _
   IgnorePrintAreas:=False, _
   OpenAfterPublish:=True

Private Function LocalFullName$(ByVal fullPath$)
  Dim ii&
  Dim iPos&
  Dim oneDrivePath$
  Dim endFilePath$

  If Left(fullPath, 8) = "https://" Then
    If InStr(1, fullPath, "my.sharepoint.com") <> 0 Then
      iPos = InStr(1, fullPath, "/Documents") + Len("/Documents")
      endFilePath = Mid(fullPath, iPos)
    Else
      iPos = 8
      For ii = 1 To 2
        iPos = InStr(iPos + 1, fullPath, "/")
      Next ii
      endFilePath = Mid(fullPath, iPos)
    End If
    endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
    For ii = 1 To 3
      oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive"))
      If 0 < Len(oneDrivePath) Then
        LocalFullName = oneDrivePath & endFilePath
        Exit Function
      End If
    Next ii
    LocalFullName = vbNullString
  Else
    LocalFullName = fullPath
  End If
End Function

我无法在无效代码中应用全名。

Answer 1

我在这个 site 上找到了一个函数。

Public Sub Main()
   NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

   strFileFolder = strOneDriveLocalFilePath
   ActiveWorkbook.SaveCopyAs strFileFolder & "\" & NewName & ".xlsx"
   ActiveWorkbook.Close SaveChanges:=False
End Sub

Private Function strOneDriveLocalFilePath() As String
On Error Resume Next 'invalid or non existin registry keys check would evaluate error
    Dim ShellScript As Object
    Dim strOneDriveLocalPath As String
    Dim strFileURL As String
    Dim iTryCount As Integer
    Dim strRegKeyName As String
    Dim strFileEndPath As String
    Dim iDocumentsPosition As Integer
    Dim i4thSlashPosition As Integer
    Dim iSlashCount As Integer
    Dim blnFileExist As Boolean
    Dim objFSO As Object
    
    strFileURL = ThisWorkbook.path
    
    'get OneDrive local path from registry
    Set ShellScript = CreateObject("WScript.Shell")
    '3 possible registry keys to be checked
    For iTryCount = 1 To 3
        Select Case (iTryCount)
            Case 1:
                strRegKeyName = "OneDriveCommercial"
            Case 2:
                strRegKeyName = "OneDriveConsumer"
            Case 3:
                strRegKeyName = "OneDrive"
        End Select
        strOneDriveLocalPath = ShellScript.RegRead("HKEY_CURRENT_USER\Environment\" & strRegKeyName)
        'check if OneDrive location found
        If strOneDriveLocalPath <> vbNullString Then
            'for commercial OneDrive file path seems to be like "https://companyName-my.sharepoint.com/personal/userName_domain_com/Documents" & file.FullName)
            If InStr(1, strFileURL, "my.sharepoint.com") <> 0 Then
                'find "/Documents" in string and replace everything before the end with OneDrive local path
                iDocumentsPosition = InStr(1, strFileURL, "/Documents") + Len("/Documents") 'find "/Documents" position in file URL
                strFileEndPath = Mid(strFileURL, iDocumentsPosition, Len(strFileURL) - iDocumentsPosition + 1)  'get the ending file path without pointer in OneDrive
            Else
                'do nothing
            End If
            'for personal onedrive it looks like "https://d.docs.live.net/d7bbaa#######1/" & file.FullName, _
            '   by replacing "https.." with OneDrive local path obtained from registry we can get local file path
            If InStr(1, strFileURL, "d.docs.live.net") <> 0 Then
                iSlashCount = 1
                i4thSlashPosition = 1
                Do Until iSlashCount > 4
                    i4thSlashPosition = InStr(i4thSlashPosition + 1, strFileURL, "/")   'loop 4 times, looking for "/" after last found
                    iSlashCount = iSlashCount + 1
                Loop
                strFileEndPath = Mid(strFileURL, i4thSlashPosition, Len(strFileURL) - i4thSlashPosition + 1)  'get the ending file path without pointer in OneDrive
            Else
                'do nothing
            End If
        Else
            'continue to check next registry key
        End If
        If Len(strFileEndPath) > 0 Then 'check if path found
            strFileEndPath = Replace(strFileEndPath, "/", "\")  'flip slashes from URL type to File path type
            strOneDriveLocalFilePath = strOneDriveLocalPath & strFileEndPath    'this is the final file path on Local drive
            'verify if file exist in this location and exit for loop if True
            If objFSO Is Nothing Then Set objFSO = CreateObject("Scripting.FileSystemObject")
            If objFSO.FileExist(strOneDriveLocalFilePath) Then
                blnFileExist = True     'that is it - WE GOT IT
                Exit For                'terminate for loop
            Else
                blnFileExist = False    'not there try another OneDrive type (personal/business)
            End If
        Else
            'continue to check next registry key
        End If
    Next iTryCount
    'display message if file could not be located in any OneDrive folders
    If Not blnFileExist Then MsgBox "File could not be found in any OneDrive folders"
    
    'clean up
    Set ShellScript = Nothing
    Set objFSO = Nothing
End Function