Excel VBA to Update Word InlineShapes Alternate Text using Heading 1 Alternate Text on Same Page

pmrsed

New Member
Joined
Jan 26, 2019
Messages
7
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
```
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

Forum statistics

Threads
1,212,927
Messages
6,110,733
Members
448,294
Latest member
jmjmjmjmjmjm

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top