另存为文件并将其在桌面上的图标移动到原始文件的相同旧位置

我已将以下代码用于工作簿（另存为），然后删除原始文件。
Windows 操作系统将新创建的文件放在“我的桌面”上第一个左侧的空闲空间上。
使用后我需要什么SaveAs，是将其图标移动到桌面上原始文件的相同旧位置。
意思是，如果我的文件最初放置在桌面的右上角，我想在使用“另存为”后将其保留在该位置。
预先感谢您抽出时间提供帮助。

Sub Rename_Me_Automatic()
 
    Application.DisplayAlerts = False
 
    Dim FilePath As String, wb As Workbook, FolderPath As String
    Dim oldName As String, newName As String
 
    Set wb = ThisWorkbook
     FilePath = wb.FullName
      FolderPath = wb.Path & Application.PathSeparator
       oldName = wb.Name
 
     newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20)
 
     wb.SaveAs FolderPath & newName
 
     Kill FilePath   'delete orginal file
 
     Application.DisplayAlerts = True
 
End Sub

请也尝试一下这个代码。它使用经典的 Windows 行为。 VBA 编写 VBScript、创建文件并运行它。该脚本找到打开的 Excel 会话、正在讨论的工作簿、保存、关闭它、在某些情况下退出 Excel 应用程序，然后仅在此之后更改工作簿名称（保持相同的文件图标位置）。最后，脚本自杀了：

Sub SaveAndChangeActiveWorkbookName_VBScript()
     Dim vbsStr As String, fso As Object, vbsObj As Object, strVBSPath As String
     Dim newName As String, wb As Workbook, ext As String, searchName As String
     
     Set wb = ThisWorkbook
     With wb
        ext = Split(.Name, ".")(UBound(Split(.Name, ".")))
        searchName = Left(.Name, Len(.Name) - (Len(ext) + 1))
     End With
     
     newName = searchName & WorksheetFunction.RandBetween(5, 20) & "." & ext
     
     strVBSPath = ThisWorkbook.Path & "\Rename.vbs" 'the fullname of the VBScript to be created and run
     
     vbsStr = "Dim objExcel, wb, objFile, FSO, fullName" & vbCrLf & _
            "Set objExcel = GetObject(, ""Excel.Application"")" & vbCrLf & _
            "Set FSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
            " Set wb = objExcel.Workbooks(""" & ThisWorkbook.Name & """)" & vbCrLf & _
            "fullName = wb.FullName" & vbCrLf & _
            "wb.Close True" & vbCrLf & _
            "If objExcel.Workbooks.Count = 0 Then" & vbCrLf & _
            "   objExcel.Quit" & vbCrLf & _
            "ElseIf objExcel.Workbooks.Count = 1 Then" & vbCrLf & _
            "    If not UCase(Workbooks(1).Name) = ""PERSONAL.XLSB"" Then" & vbCrLf & _
            "         objExcel.Quit" & vbCrLf & _
            "    End If" & vbCrLf & _
            "End If" & vbCrLf & _
            "Set objFile = FSO.GetFile(fullName)" & vbCrLf & _
            "objFile.Name = """ & newName & """" & vbCrLf & _
            "FSO.DeleteFile Wscript.ScriptFullName, True" 'kill itself...
                        
     Set fso = CreateObject("Scripting.FileSystemObject")
     Set vbsObj = fso.OpenTextFile(strVBSPath, 2, True)
            vbsObj.Write vbsStr 'write the above string in the VBScript file
     vbsObj.Close
      
      Shell "cmd.exe /c """ & strVBSPath & """", 0  'execute/run the VBScript
End Sub

下一个版本尝试简化您的代码，不需要任何 API：

Sub SaveAndChangeActiveWorkbookName_ShellAppl()
   Dim sh32 As Object, oFolder As Object, oFolderItem As Object, wb As Workbook
   Dim newName As String, ext As String, searchName As String
   
   Set sh32 = CreateObject("Shell.Application")
   Set wb = ThisWorkbook
   
   With wb
     ext = Split(.Name, ".")(UBound(Split(.Name, ".")))            'extract extension
     searchName = Left(.Name, Len(.Name) - (Len(ext) + 1)) 'extract the rest of its name
     
     newName = searchName & WorksheetFunction.RandBetween(5, 20) & _
                                                                        IIf(showExtension, "." & ext, "") 'it sets correct new name...

     .Save
     .ChangeFileAccess xlReadOnly '!
     
     Set oFolder = sh32.Namespace(.Path & "\")
     Set oFolderItem = oFolder.ParseName(.Name)
     oFolderItem.Name = newName
     
     If (UCase(Workbooks(1).Name) = "PERSONAL.XLSB" _
            And Workbooks.Count = 2) Or Workbooks.Count = 1 Then
         Application.Quit
     Else
        .Close False 'no need to save it again and it closes faster in this way...
     End If
   End With
End Sub

'Function to check how 'Hide extension for known file type' is set:
Function showExtension() As Boolean
   Dim fileExt As String, Shl As Object, hideExt As Long
   
   fileExt = "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt"
   Set Shl = CreateObject("WScript.Shell")
   hideExt = Shl.RegRead(fileExt)
   If hideExt = 0 Then showExtension = True
End Function

我了解到 Windows 不允许更改打开的工作簿的名称。确实如此，您无法手动执行此操作。 Windows不让你这样做，这是它避免数据丢失的哲学。

但设置ReadOnlyfile 属性会暂时从 Windows 文件分配表中删除文件全名。如果你试试Debug.Print wb.FullFileName在更改其属性之前和之后，它将显示相同的（旧的）属性。但看起来有办法做到这一点，让打开的工作簿在分配表之外，您可以更改其名称。我什至没有想到这是可能的，我认为这是我今天学到的最重要的问题。