×
INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Excel VBA to Update Word InlineShape using Heading 1 Alternative Text

Excel VBA to Update Word InlineShape using Heading 1 Alternative Text

Excel VBA to Update Word InlineShape using Heading 1 Alternative Text

(OP)
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
```

RE: Excel VBA to Update Word InlineShape using Heading 1 Alternative Text

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

CODE

    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
                'Get heading text
                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 

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Tek-Tips Forums free from inappropriate posts.
The Tek-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Tek-Tips forums is a member-only feature.

Click Here to join Tek-Tips and talk with other members! Already a Member? Login

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close