SaveAs a file and move it’s icon on Desktop to the same old position of the original file

I have used the below code to a workbook (SaveAs) and then delete the original file.
The Windows OS put the new created file on the first left vacant space on My Desktop.
What I need after using SaveAs , is to move it’s icon to the same old position of the original file on my Desktop.
Meaning, If my file is initially placed on the upper right of my desktop , I want to keep it in that location after using SaveAs.
In advance, appreciate for your time to help.

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

Please, also try this code. It uses classical Windows behavior. VBA writes a VBScript, creates the file and runs it. The script finds the open Excel session, the workbook in discussion, save, close it, quits Excel application in certaing circumstances and changes the workbook name only after that (keeping the same file icon position). Finally, the script kills itself:

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

The next version tries simplifying your code, not needing any 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

I've been educated that Windows does not allow changing name of an open workbook. Which is true, you cannot do it manually. Windows does not let you do it, this is its philosophy to avoid data loss.

But setting ReadOnly file attribute looks to temporarily remove the file full name from the Windows File Allocation Table. If you try Debug.Print wb.FullFileName before and after changing its attribute, it will show the same (old) one. But it looks that there are ways to do it and letting the open workbook outside the Allocation Table, you can change its name. I did not even imagine this is possible and I consider that this is the most important issue I learned today.