excel - 从 onedrive VBA 上的工作表在同一文件夹上创建一个新工作簿
问题描述
我有一个代码如下。它正在复制工作表并将其另存为同一文件夹中的新工作簿,并打开活动工作簿。对话框打开,用户为此新工作簿键入新名称。但是,自从公司将文件夹移至 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
我不能在不工作的代码中应用全名。
解决方案
我在这个网站上找到了一个功能。
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
推荐阅读
- c++ - 我需要比较 2 个字符串中的内容
- mariadb - 从同一个表中删除相同的记录会导致死锁
- python - 使用 Python 将 word 文件中的多个表提取到 Excel 文件
- r - R:如何将 rlangs .data 功能与 magrittrs 管道点结合使用?
- bash - 使用 bash 通过具有特定尺寸和位置的终端打开 google chrome
- c# - 试图在响应中隐藏一个属性,但仍然获得它的子属性
- arduino - Wemos D1 R2 板无法连接到 wifi 超过 10 秒
- php - 如何根据mysql中的最后一个条目创建序列号
- nginx - Nginx 在上游响应日志中显示 2 种不同的状态
- elasticsearch - 在logstash elasticsearch中将_Id设置为更新键