Excel VBA to Update Word InlineShape using Heading 1 Alternative Text

[pmrsed]

Is there a way to get the Word Page number of the InlineShape identified as needing its Alt Text updated and then use that Page Number to grab the Heading 1 Text (on the same page above the Shape)?

I have an Excel VBA macro working with a Word document containing some InlineShapes that do not have Alternative Text (TITLE). Not all Inline Shapes are missing the Alt Text. The macro is supposed to grab the Heading 1 Text from the same page that is positioned above the Shape missing the Alternative Text. This all takes place after placing a bold border around the Shapes. That piece is working.
==========================================================================================
Layout of Word doc:

== New Page ==
Heading 1 Text

- Sentences -

InlineShape (bitmap, etc.)

- Sentences -

== New Page ==
Heading 1 Text

- Sentences -

InlineShape (bitmap, etc.)

- Sentences -
etc.
etc.

My macro successfully identifies the Shapes needing Alt Text updates - but it is not grabbing the Heading 1 text above the Shape that is to be used to update the Shape's Alt Text.

I was thinking that when I found a Shape w/o Alt Text on a certain page I could get the Heading 1 text above using the wdParagraph approach. Something like:

ActiveDocument.Range.MoveStart wdParagraph, -1 (or some variation thereof)
or -
ActiveDocument.Range.GOTO What:=wdGoToHeading, Which:==wdGoToPrevious

Neither approach works because there is no 'pointer' to use when attempting to grab the Heading 1 text based off of the Shape location (other than page number). This is because I'm indexing ActiveDocument.InlineShapes.Item(i).Title with subscripts and control hasn't been passed (range) to that particular page that the Shape needing update resides on.

```
Option Explicit
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim strFileToOpen$, strAltText$, strUpdateAltText$, strPath$, strInputBoxText$, strInputBoxText1$, strSelectionInput$, strSelectionInput1$, _
strGetOpenFilename$, strErrMessage$, strGetText$, strSearchArgument$, strEnv$, strEffDate$, strEffTime$, _
strMessage$, strTitle$, Auto_Fill_Command_Button$, strSearchField$, intLastRow$, intStringPosition$
Dim Num%, Answer%, intExtendedRows%, Year%, i%, j%, k%, m%, intRowCnt%, intFCTRowStart%, _
intPCTRowStart%, intPPTRowStart%, intRowMax%
Dim CurPage As Integer
Dim StrHd As String
Dim blnFound As Boolean
Dim oshp As InlineShape
Dim currentRange As Word.Range
Dim strAlt_text
Dim x As Integer
Dim heading As Range

Public Sub Update_Alt_text_in_Word_document()

Err.Number = 0
On Error GoTo errorHandler
Application.CutCopyMode = True
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Application.StatusBar = True
ThisWorkbook.Sheets("Button").Activate
ThisWorkbook.Sheets("Button").Select

On Error Resume Next

strFileToOpen = ""
strInputBoxText = ""
strPath = ActiveDocument.Path

If strPath = "" Then
strPath = ActiveWorkbook.Path
End If


strPath = strPath & "\"
Set wrdApp = GetObject(, "Word.Application")
strFileToOpen = wrdApp.ActiveDocument.Name

Call FileDialog_Open_MER

If strFileToOpen = "False.docx" Or strFileToOpen = "" Then
GoTo GetMeOut
End If

strAlt_text = ""

'strAltText = InputBox("Enter Alt Text: " & vbLf & vbLf & strFileToOpen)
'If strAltText = "" Then
' GoTo GetMeOut
'End If

If strFileToOpen = "false.docx" Then
GoTo GetMeOut
End If

If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open(strPath & strFileToOpen)
Else
On Error GoTo notOpen
Set wrdDoc = wrdApp.Documents(strPath & strFileToOpen)
notOpen:
Set wrdDoc = wrdApp.Documents.Open(strPath & strFileToOpen)
End If

On Error GoTo 0
wrdApp.Visible = True

ActiveDocument.Range.Expand Unit:=wdParagraph
ActiveDocument.Range.MoveStart wdParagraph, 5


For i = 1 To ActiveDocument.InlineShapes.Count
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(i).Type <> wdInlineShapePicture Then
' nothing
Else
If ActiveDocument.InlineShapes.Item(i).Title <> "" Then
'nothing
Else
'create the border black with font size 10
ActiveDocument.InlineShapes.Item(i).Line.BackColor = vbBlack
ActiveDocument.InlineShapes.Item(i).Line.Weight = 2
'change the border style to single
ActiveDocument.InlineShapes.Item(i).Line.Style = msoLineSingle
ActiveDocument.Range.GoTo What:=wdGoToHeading, Which:=wdGoToPrevious
Set ActiveDocument.Range = Selection.GoTo(What:=wdGoToHeading, Which:=wdGoToPrevious)
MsgBox ActiveDocument.Range.Text
strAlt_text = ActiveDocument.Range.Text
ActiveDocument.Selection.Shapes(i).AlternativeText = strAlt_text
Application.StatusBar = "Alternate Text update #" & i & " Title: " _
& ActiveDocument.InlineShapes.Item(i).Title
End If
End If
Next i


ActiveDocument.Close _
SaveChanges:=wdPromptToSaveChanges, _
OriginalFormat:=wdPromptUser

errorHandler:
If Err.Number = 4198 Then
MsgBox "Document was not Closed"
End If

GetMeOut:
Auto_Fill_Command_Button = "0"
strFileToOpen = ""
'wrdApp.Visible = False
Set wrdDoc = Nothing
Set wrdApp = Nothing

End Sub

Public Sub FileDialog_Open_MER()
Dim FD As FileDialog

If strFileToOpen = "" Then
ChDir strPath
Set FD = Application.FileDialog(msoFileDialogOpen)
FD.Show
If FD.SelectedItems.Count <> 0 Then
strFileToOpen = FD.SelectedItems(1)
strPath = ""
ThisWorkbook.Sheets("Button").Activate
ThisWorkbook.Sheets("Button").Select
Else
ThisWorkbook.Sheets("Button").Activate
ThisWorkbook.Sheets("Button").Select
Exit Sub
End If
Else
Exit Sub
End If

MsgBox "Word doc selected for Alt Text updates is:" & strFileToOpen
wrdApp.Visible = True
wrdApp.Activate

End Sub
```

 

[strongm]

This minor modification of the main loop of your code should do the trick

[blue]    For i = 1 To ActiveDocument.InlineShapes.Count
        [COLOR=green]'check if the current shape is an picture[/color]
        If ActiveDocument.InlineShapes.Item(i).Type <> wdInlineShapePicture Then
        [COLOR=green]' nothing[/color]
        Else
            If ActiveDocument.InlineShapes.Item(i).Title <> "" Then
                [COLOR=green]'nothing[/color]
            Else
                [COLOR=green]'create the border black with font size 10[/color]
                ActiveDocument.InlineShapes.Item(i).Line.BackColor = vbBlack
                ActiveDocument.InlineShapes.Item(i).Line.Weight = 2
                [COLOR=green]'change the border style to single[/color]
                ActiveDocument.InlineShapes.Item(i).Line.Style = msoLineSingle
                [COLOR=green]'Get heading text[/color]
                Set heading = Selection.GoTo(What:=wdGoToHeading, Which:=wdGoToPrevious)
                heading.Expand Unit:=wdParagraph
                strAlt_text = heading.Text
                ActiveDocument.InlineShapes.Item(i).AlternativeText = strAlt_text
                Application.StatusBar = "Alternate Text update #" & i & " Title: " _
                & ActiveDocument.InlineShapes.Item(i).Title
            End If
        End If
    Next i[/blue]