Macro needs to ignore text on desktop

I have a macro to automatically rename the page which works fine but sometimes I will make a copy of the page and pull it off onto the desktop. If I don't delete the text string from the copy, the macro will just error. I need a way to have the macro ignore the desktop objects during the search. I'm not a coder so I used ChatGPT to create this code.  The macro does a few other updates based on text strings but they all have the same problem with throwing an error because the macro doesn't ignore the desktop copy.

Sub UpdateFileInfo()
Dim doc As Document
Dim totalPages As Long
Dim page As page
Dim shp As Shape
Dim newText As String
Dim currentDate As String
Dim pageTitle As String

' Get the current date from the system
currentDate = Format(Date, "MMMM d, yyyy") ' Example: January 20, 2025

' Reference the active document
Set doc = ActiveDocument
totalPages = doc.Pages.Count

' Loop through each page in the document
For Each page In doc.Pages
' Activate the current page
page.Activate

' Search for the text object named "PageString"
Set shp = page.Shapes.FindShape(Name:="PageString")
If Not shp Is Nothing Then
' Construct the new text: "Sheet * of #"
newText = "Sheet " & page.Index & " of " & totalPages

' Update the shape's text
shp.Text.Story = newText
End If

' Search for the text object named "DateString"
Set shp = page.Shapes.FindShape(Name:="DateString")
If Not shp Is Nothing Then
' Replace the text with the current date
shp.Text.Story = currentDate
End If

' Search for the text object named "ST_PgTitle"
Set shp = page.Shapes.FindShape(Name:="ST_PgTitle")
If Not shp Is Nothing Then
' Get the text content of the object
pageTitle = shp.Text.Story

' Replace any returns (line breaks) with spaces
pageTitle = Replace(pageTitle, vbCr, " ")
pageTitle = Replace(pageTitle, vbLf, " ")

' Rename the page to match the cleaned text
page.Name = pageTitle
End If
Next page

MsgBox "Page numbers, dates, and titles updated successfully!", vbInformation, "Update Pages"
End Sub

 

  • Add this function to your code

    Function FindDeskTopShape(P As Page, shName$) As Shape
    Dim sr As ShapeRange, s As Shape
        Set sr = P.FindShapes(shName)
        For Each s In sr
            If (s.LeftX >= 0) And (s.RightX <= P.SizeWidth) Then
                If (s.BottomY >= 0) And (s.TopY <= P.SizeHeight) Then
                    Set FindDeskTopShape = s
                    Exit Function
                End If
            End If
        Next s
        Set FindDeskTopShape = Nothing
    End Function
    

    and change lines


    Set shp = page.Shapes.FindShape(Name:="PageString")
    Set shp = page.Shapes.FindShape(Name:="DateString")
    Set shp = page.Shapes.FindShape(Name:="ST_PgTitle")

    to

    Set shp = FindDeskTopShape(page, "PageString")
    Set shp = FindDeskTopShape(page, "DateString")
    Set shp = FindDeskTopShape(page, "ST_PgTitle")