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")
Thanks! That worked beautifully.