如何让Excel通过SaveAs生成的文件图标保留原桌面位置？

要实现SaveAs后新文件继承原文件的桌面图标位置，需要借助Windows Shell对象读取原文件的坐标信息，再将其应用到新文件上。VBA本身无法直接操作桌面图标位置，以下是修改后的完整代码：

Sub Rename_Me_Automatic()
    Application.DisplayAlerts = False
    
    Dim FilePath As String, wb As Workbook, FolderPath As String
    Dim oldName As String, newName As String
    Dim desktopPath As String
    Dim objShell As Object, objDesktopFolder As Object
    Dim objOldFile As Object, objNewFile As Object
    Dim posX As Variant, posY As Variant
    
    Set wb = ThisWorkbook
    FilePath = wb.FullName
    FolderPath = wb.Path & Application.PathSeparator
    oldName = wb.Name
    
    ' 获取桌面路径，判断当前文件是否在桌面
    desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Dim isOnDesktop As Boolean
    isOnDesktop = (StrComp(FolderPath, desktopPath & Application.PathSeparator, vbTextCompare) = 0)
    
    ' 如果文件在桌面，先读取原文件的图标位置
    If isOnDesktop Then
        Set objShell = CreateObject("Shell.Application")
        Set objDesktopFolder = objShell.Namespace(desktopPath)
        Set objOldFile = objDesktopFolder.ParseName(oldName)
        
        ' 获取原文件的坐标
        posX = objOldFile.ExtendedProperty("System.ItemPosition.X")
        posY = objOldFile.ExtendedProperty("System.ItemPosition.Y")
    End If
    
    ' 生成新文件名并保存（补充扩展名+指定格式）
    newName = Left(oldName, Len(oldName) - 5) & WorksheetFunction.RandBetween(1, 20) & ".xlsm"
    wb.SaveAs FolderPath & newName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
    ' 删除原文件
    Kill FilePath
    
    ' 如果文件在桌面，设置新文件的图标位置
    If isOnDesktop Then
        ' 等待系统识别新文件
        Application.Wait Now + TimeValue("00:00:01")
        Set objNewFile = objDesktopFolder.ParseName(newName)
        If Not objNewFile Is Nothing Then
            objNewFile.ExtendedProperty("System.ItemPosition.X") = posX
            objNewFile.ExtendedProperty("System.ItemPosition.Y") = posY
            ' 刷新桌面使位置生效
            objShell.Namespace(desktopPath).Items.InvokeVerb("Refresh")
        End If
    End If
    
    ' 释放对象
    Set objOldFile = Nothing
    Set objNewFile = Nothing
    Set objDesktopFolder = Nothing
    Set objShell = Nothing
    Set wb = Nothing
    
    Application.DisplayAlerts = True
End Sub

关键说明： #

• 桌面位置判断：先检查文件是否在桌面，非桌面文件无需处理图标位置
• 坐标读取与设置：通过Shell.Application获取桌面文件夹对象，读取原文件的System.ItemPosition.X/Y属性保存坐标，再赋值给新文件
• 系统等待与刷新：添加1秒等待和桌面刷新操作，确保系统能识别新生成的文件，避免位置设置失败
• 文件格式指定：明确指定宏启用工作簿格式，避免SaveAs时自动变更文件格式导致兼容性问题

内容的提问来源于stack exchange，提问作者Waleed