How to extarct all alternative texts from all pictures to newdocument?

[avkokin]

Hello.
There is one document which has many pictures (embeded and linked).
Linked pictures has alternative texts. I want to create new document
and insert these alternative text from every picture to the table
within new document. I tried next macro (below), but I can't do good
work it. Please give me any tips.
Thank you.
My macro:

Sub extractAltText_to_NewDoc()
'
Dim alText As String
Dim nAltext As Long
Dim oShape As InlineShape
Dim oSec As Section
Dim oTable As Table
Dim i As Integer
Dim oRange As Range
Dim newDoc As Document
Dim actDoc As Document
Dim ptWidth As Single

Application.ScreenUpdating = False

Set newDoc = Documents.Add
With newDoc.PageSetup
ptWidth = PicasToPoints(51) - (.RightMargin + .LeftMargin)
End With
Set oTable = newDoc.Tables.Add(Selection.Range, nAltext + 1, 2)
With oTable
.Borders.Enable = True
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
.Rows.AllowBreakAcrossPages = False
.TopPadding = PicasToPoints(0.5)
.BottomPadding = PicasToPoints(0.5)
.Columns(1).PreferredWidth = ptWidth * 0.65
.Columns(2).PreferredWidth = ptWidth * 0.35
End With
With oTable.Cell(1, 1).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Alternative text"
End With
With oTable.Cell(1, 2).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Page number"
End With

For Each oSec In ActiveDocument.Sections
For Each oShape In ActiveDocument.InlineShapes
alText = oShape.AlternativeText
If oShape.Type = wdInlineShapeLinkedPicture And Len(alText)
<> 0 Then
nAltext = ActiveDocument.InlineShapes.Count

For i = 1 To nAltext
Application.StatusBar = "Add " & nAltext & " to table:
" & i
With oTable.Cell(i + 1, 1).Range
.Font.Name = "Arial"
.Font.Size = 11
.InsertAfter alText
End With
With oTable.Cell(i + 1, 2).Range
.Font.Name = "Arial"
.Font.Size = 14
.InsertAfter
CStr(Selection.Information(wdActiveEndPageNumber))
End With
Next i

ElseIf oShape.Type = wdInlineShapePicture Then
i = i + 1
End If
Next oShape
Next oSec

End Sub

 

[StevenM]

To: A.V. Kokin,

I don't have much experience working with such documents, but if you'll post
a mock-up of your document on the web, or e-mail a mock-up to me, I'll step
through your code and take a look at it.

Steven Craig Miller

stevencraigmiller(at)comcast(dot)net
(Make the obvious substitutions)

 

[akokin]

Hello Steven. Thank you.
I shared all folder with document and images for it (TestLinkedPic.zip) on
box.net. That is: http://www.box.net/shared/06yvpdeky5

Sincerely, Anton Kokin

 

[Helmut Weber]

Hi Anton,

I suggest, you create a doc with a table of
the specifications in your macro.
Here it is "c:\test\word1\picturestable.doc".
You seem to have no difficulty with page setup
and table formatting. Therefore I skip the code for that.

Then, try the following:

Sub extractAltText_to_AnotherDoc()
'
Dim iShp As InlineShape
Dim Doc1 As Document
Dim doc2 As Document
Set Doc1 = ActiveDocument
Set doc2 = Documents.Open("c:\test\word1\picturestable.doc")
Doc1.Activate
For Each iShp In ActiveDocument.InlineShapes
If iShp.Type = wdInlineShapeLinkedPicture Then
If iShp.AlternativeText <> "" Then
doc2.Tables(1).Rows.Add
doc2.Tables(1).Rows.Last.Cells(1).Range.Text = _
iShp.AlternativeText
doc2.Tables(1).Rows.Last.Cells(2).Range.Text = _
iShp.Range.Information(wdActiveEndPageNumber)
End If
End If
Next iShp
End Sub

You can handle the formatting afterwards.

--

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Vista Small Business, Office XP

 

[avkokin]

Hi Helmut.
Thank you very much!

 

[StevenM]

To: A. Kokin

I got your code to work, whether or not it works as you want it too, that is
for you to judge since I'm unsure what you wanted. But allow me to make a few
observations about your code.

When you create a new document, that new document then becomes the (new)
active document as opposed to the earlier active document. So before you
create a new document, you need to have a line like:

Set actDoc = ActiveDocument

Now when you create a new document you can refer to the old active document
with the variable "actDoc" even though it is no longer the current active
document.

Another problem with your code was that you tried using the variable nAltext
before defining its value. Later in your code I found the line:

nAltext = ActiveDocument.InlineShapes.Count

The value of nAltext was always zero because the then "ActiveDocument" was
the new document you just created and it had no inline shapes in it. I
changed it to:

nAltext = actDoc.InlineShapes.Count

and moved it forward.

Your code had:

For Each oSec In ActiveDocument.Sections
For Each oShape In ActiveDocument.InlineShapes
'lines omitted
For i = 1 To nAltext

I couldn't figure out what you were trying to do with the above lines, so I
simplified things to:

For i = 1 To nAltext

--- cut here ---

Sub extractAltText_to_NewDoc()
Dim alText As String
Dim nAltext As Long
Dim oTable As Table
Dim i As Integer
Dim newDoc As Document
Dim actDoc As Document
Dim ptWidth As Single

Application.ScreenUpdating = False
Set actDoc = ActiveDocument
nAltext = actDoc.InlineShapes.Count

Set newDoc = Documents.Add
With newDoc.PageSetup
ptWidth = PicasToPoints(51) - (.RightMargin + .LeftMargin)
End With
Set oTable = newDoc.Tables.Add(Selection.Range, nAltext + 1, 2)
With oTable
.Borders.Enable = True
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
.rows.AllowBreakAcrossPages = False
.TopPadding = PicasToPoints(0.5)
.BottomPadding = PicasToPoints(0.5)
.Columns(1).PreferredWidth = ptWidth * 0.65
.Columns(2).PreferredWidth = ptWidth * 0.35
End With
With oTable.Cell(1, 1).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Alternative text"
End With
With oTable.Cell(1, 2).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Page number"
End With

For i = 1 To nAltext
Application.StatusBar = "Add " & nAltext & " to table:" & i
alText = actDoc.InlineShapes(i).AlternativeText
actDoc.InlineShapes(i).Select
With oTable.Cell(i + 1, 1).Range
.Font.Name = "Arial"
.Font.Size = 11
.InsertAfter alText
End With
With oTable.Cell(i + 1, 2).Range
.Font.Name = "Arial"
.Font.Size = 14
.InsertAfter CStr(Selection.Information(wdActiveEndPageNumber))
End With
Next i
Application.ScreenUpdating = True
End Sub


--- cut here ---

There were other things I didn't understand, but perhaps the above will
serve as a starting point for further improvements.

Steven Craig Miller

 

[avkokin]

There were other things I didn't understand, but perhaps the above will

serve as a starting point for further improvements.

Steven Craig Miller

Hello Steven. Thank you very much and your explanations. Sincerely,
Anton Kokin.

 

[avkokin]

That code (below) is good worked, but it creates empty rows within
table. I wish to get rows only with alternative text of linked
pictures, without empty rows. How? Thank you.

Sub extractAltText_to_NewDoc()
Dim alText As String
Dim nAltext As Long
Dim oShape As InlineShape
Dim oTable As Table
Dim i As Integer
Dim a As Integer
Dim newDoc As Document
Dim actDoc As Document
Dim ptWidth As Single
Application.ScreenUpdating = False
Set actDoc = ActiveDocument
Set newDoc = Documents.Add
nAltext = actDoc.InlineShapes.Count
With newDoc.PageSetup
ptWidth = PicasToPoints(51) - (.RightMargin + .LeftMargin)
End With
Set oTable = newDoc.Tables.Add(Selection.Range, nAltext + 1, 2)
With oTable
.Borders.Enable = True
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
.Rows.AllowBreakAcrossPages = False
.TopPadding = PicasToPoints(0.5)
.BottomPadding = PicasToPoints(0.5)
.Columns(1).PreferredWidth = ptWidth * 0.65
.Columns(2).PreferredWidth = ptWidth * 0.35
End With
With oTable.cell(1, 1).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Alternative Text"
End With
With oTable.cell(1, 2).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Page Number"
End With
For i = 1 To nAltext

If actDoc.InlineShapes(i).Type = wdInlineShapeLinkedPicture And
Len(actDoc.InlineShapes(i).AlternativeText) <> 0 Then

alText = actDoc.InlineShapes(i).AlternativeText ' here all
alt.text, but need only for linked pictures (???)
Application.StatusBar = "Add " & nAltext & " to table: " & i
actDoc.InlineShapes(i).Select
With oTable.cell(i + 1, 1).Range
.Font.Name = "Arial"
.Font.Size = 11
.InsertAfter alText
End With
With oTable.cell(i + 1, 2).Range
.Font.Name = "Arial"
.Font.Size = 14
.InsertAfter Selection.Information(wdActiveEndPageNumber)
End With

ElseIf actDoc.InlineShapes(i).Type = wdInlineShapeEmbeddedOLEObject
Then
a = a + 1
End If

Next i
actDoc.Activate
Selection.HomeKey wdStory
Application.ScreenUpdating = True
Set newDoc = Nothing
Set actDoc = Nothing
End Sub

 

[StevenM]

To: A.V. Kokin,

Add among your "dim" statements the following:

Dim oRow As Row

And then towards the end of your macro, after your "Next i" statement, add:

For Each oRow In oTable.rows
If Len(oRow.Cells(1).Range.Text) = 2 Then oRow.Delete
Next oRow

Empty cells in a table have a length of 2 characters. The above lines of
code check the first column of each row in oTable looking for cells which are
empty (Len = 2), and if it finds an empty cell, it deletes that row.

Steven Craig Miller

 

[avkokin]

Thank you very much!
Sincerely, Anton Kokin

 

[avkokin]

Steve, I found one strangeness. The result table has alternative text
for picture which isn't linked. This picture has alternative text but
isn't linked. So is I want to exclude not linked pictutes.
Alas! óonsequently our macro works uncorrect. Sorry.

Sincerely, Anton Kokin

 

[avkokin]

I decided this problem next way: I used code by Helmut and I had next
macro:

Sub extract_Alt_Text()
'
Dim altext As String
Dim nAltext As Long
Dim oShape As InlineShape
Dim oTable As Table
Dim oRow As row
Dim newDoc As Document
Dim actDoc As Document
Dim ptWidth As Single

Application.ScreenUpdating = False

Set actDoc = ActiveDocument
Set newDoc = Documents.Add

nAltext = actDoc.InlineShapes.Count

With newDoc.PageSetup
ptWidth = PicasToPoints(51) - (.RightMargin + .LeftMargin)
End With

Set oTable = newDoc.Tables.Add(Selection.Range, nAltext + 1, 2)

With oTable
.Borders.Enable = True
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
.Rows.AllowBreakAcrossPages = False
.TopPadding = PicasToPoints(0.5)
.BottomPadding = PicasToPoints(0.5)
.Columns(1).PreferredWidth = ptWidth * 0.65
.Columns(2).PreferredWidth = ptWidth * 0.35
End With
With oTable.cell(1, 1).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Alternative text"
End With
With oTable.cell(1, 2).Range
.Font.Name = "Arial"
.Font.Bold = True
.InsertAfter "Page Number"
End With

For Each oShape In actDoc.InlineShapes
If oShape.Type = wdInlineShapeLinkedPicture And
Len(oShape.AlternativeText) <> 0 Then
altext = oShape.AlternativeText
oTable.Rows.Add
oTable.Rows.Last.Cells(1).Range.Text = altext
oTable.Rows.Last.Cells(2).Range.Text =
oShape.Range.Information(wdActiveEndPageNumber)
End If
Next oShape

For Each oRow In oTable.Rows
If Len(oRow.Cells(1).Range.Text) = 2 Then oRow.Delete
Next oRow

End Sub

Thank you.
Sincerely, Anton Kokin.

 

[avkokin]

And more one problem - if I using very big document (more 300 pages)
then from time to time show note about lack of memory. I wonder, if
there is a way to escape it?

 

[Helmut Weber]

Hi Anton,

often this has nothing to do with memory at all,
its a kind of error that pops up for all kinds of reasons.

http://word.mvps.org/FAQs/AppErrors/InsufficientMemory.htm

You may try to save the document every now and then,
and clear the undo-buffer, like

For Each oShape In actDoc.InlineShapes
i = i +1
if i > 10 then
newdoc.undoclear
newdoc.save
i = 0
endif

But I wonder whether this will help.

 

[avkokin]

Hello Helmut.

But I wonder whether this will help.

Thank you. I will try it in Monday when I go to my office. And I will
reply for you.