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
```
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
```
