Блог

У меня есть код, как показано ниже. Он копирует лист и сохраняет его как новую книгу в той же папке, что и активная книга.откроется диалоговое окно, и пользователь введет новое имя для этой новой книги. однако он больше не работает, так как компания переместила папки в onedrive.

 NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path amp; "" amp; NewName amp; ".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 iiamp;
  Dim iPosamp;
  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 amp; endFilePath
        Exit Function
      End If
    Next ii
    LocalFullName = vbNullString
  Else
    LocalFullName = fullPath
  End If
End Function
 

Я не могу применить полное имя внутри нерабочего кода.

Я нашел функцию на этом сайте.

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

   strFileFolder = strOneDriveLocalFilePath
   ActiveWorkbook.SaveCopyAs strFileFolder amp; "" amp; NewName amp; ".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_USEREnvironment" amp; 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" amp; 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/" amp; 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 amp; 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