WdCollapse method

[Quinn]

Hello all,
I'm searching through a large document looking for Tables and Figures.
I'm using the selection.find method keying off of .Style = "Tbl Title" for tables, .Style="Fig Title" for figures. I want to take the information and populate an Excel spreadsheet with the table and figure information. I am having trouble using the collapse method. For Tables there are two paragraphs in the heading but for Figures there is only one paragraph. I'm using the code below::

Selection.Collapse wdCollapseStart
Selection.MoveEnd wdParagraph, 2
strNames(intCount) = Selection.Paragraphs(1).Range.Text
strNames2(intCount) = Selection.Paragraphs(2).Range.Text
which works for tables but I can't get it to work for figures. Attached is an example of the document.
Quinn

[fumei]

Uh, I looked at your document and I am having a hard time understanding what you are saying.

1. There are no tables, or figures.
2. You have no code there to look at. But then you probably have the code in your normal.dot....yes?
3. You mention one paragraph for Figures, and two paragraphs for Tables. This is not in the sample document you posted.

Can you clarify?

[Quinn]

Thanks for helping,
Sorry about the confusion. The information that I need is in the table header (.style=Tbl Title)
or the figure header (.style=Fig Title) . I deleted the tables and figures, which would immediatley proceed the headers, in the document.
The upload feature on this site would only allow 19 kb of information so I really had to trim it down and hence the removal of the tables and figures.
There are two paragraphs in the example below:
the first is:
Table GHZZ.11.7. Summary of Bone Mineral Density (g/cm (http://vbaexpress.com/forum/)2)
Total Lumbar Spine
by Visit
All Enrolled Patients, Phase 1

the second would be:
[]

whereas, for the figures they always have one paragraph
Figure GHZZ.11.1. Percent change in bone mineral density total lumbar spine by visit from study baseline all enrolled patients
Phase 1. (http://vbaexpress.com/forum/)

again sorry, I guess the paragraph marks (pilcrows) got removed when I uploaded the document?
The document will contain over 100 of these table headers and figure headers which I have to cut and paste into Excel and then put the Excel into tables. Which should be automated. below is my code. I got some of the code via the recorder and some I wrote myself . It's probably painful to look at, so any suggestion would be helpful....


Dim XlWb As Excel.Workbook
Dim XlApp As Excel.Application
Dim XlWs As Excel.Worksheet

Public Sub CommandButton1_Click()

'Count the number of tables
Dim intCount As Integer
Dim intRows As Integer
'count the number of characters in the strings
Dim StrNum1() As Integer
Dim StrNum2() As Integer
Dim StrNum3() As Integer
Dim StrNum4() As Integer
Dim StrNum5() As Integer
Dim StrNum6() As Integer
Dim StrNum7() As Integer
Dim StrNum8() As Integer
Dim StrNum9() As Integer
Dim strStyle As String
Dim intPageNum() As Integer 'to get the page number of the selection
Dim strNames() As String 'break down string into substring according to soft break
Dim strNames1() As String 'string array variable for the title
Dim strNames2() As String 'string array variable for the ACDO info
Dim strNames3() As String
Dim Pnames() As String 'program name
Dim Tnames() As String 'table name
Dim Title1() As String
Dim Title2() As String
Dim Title3() As String
Dim Title4() As String

Dim objDocument As Document

' Const strRoutine As String = "Authoring.ATMacros::CopyTableFigureNames"


intCount = 1 'sets variable starting value
Selection.HomeKey wdStory 'go to the top of the document

'starts search for 'Tbl Title' or 'Fig Title'
With Selection.Find
.ClearFormatting 'clear previous formatting of find object
.Replacement.ClearFormatting 'clear previous formatting of replacement object
.Style = "Tbl Title"
.Text = ""
.Forward = True
.Wrap = wdFindStop
End With

'start searching for strStyle style in the document
While Selection.Find.Execute
'redefine the arrays to value of intcount
ReDim Preserve intPageNum(intCount)
ReDim Preserve strNames(intCount)
ReDim Preserve strNames2(intCount)
ReDim Preserve strNames1(intCount)
ReDim Preserve strNames3(intCount)
ReDim Preserve Pnames(intCount)
ReDim Preserve Tnames(intCount)
ReDim Preserve Title1(intCount)
ReDim Preserve Title2(intCount)
ReDim Preserve Title3(intCount)
ReDim Preserve Title4(intCount)


ReDim Preserve StrNum1(intCount)
ReDim Preserve StrNum2(intCount)
ReDim Preserve StrNum3(intCount)
ReDim Preserve StrNum4(intCount)
ReDim Preserve StrNum5(intCount)
ReDim Preserve StrNum6(intCount)
ReDim Preserve StrNum7(intCount)
ReDim Preserve StrNum8(intCount)
ReDim Preserve StrNum9(intCount)



'get the current page number
intPageNum(intCount) = Selection.Information(wdActiveEndPageNumber)
Selection.Collapse wdCollapseStart
Selection.MoveEnd wdParagraph, 2

strNames(intCount) = Selection.Paragraphs(1).Range.Text
strNames2(intCount) = Selection.Paragraphs(2).Range.Text
StrNum1(intCount) = InStr(1, strNames(intCount), vbTab)
StrNum2(intCount) = InStr(1, strNames(intCount), vbCr)
StrNum3(intCount) = InStr(1, strNames(intCount), Chr$(11))
If InStr(1, strNames2(intCount), "insert", 1) = 0 Then
strNames(intCount) = vbTab 'This is required to get correct number of tabs
strNames2(intCount) = ""
Else 'if not, string is broken down by soft returns then paragraph marks are removed
strNames1(intCount) = Trim$(Left$(strNames(intCount), (Len(strNames(intCount)) - _
(StrNum2(intCount) - StrNum1(intCount)))))
'strnames1 is the table information which is the 1st part of the string
'Strnames3 is the entire string of titles...
strNames3(intCount) = Trim$(Right$(strNames(intCount), (Len(strNames(intCount)) - _
StrNum1(intCount))))


'1.) count the number of characters until the sort return symbol
'2.) subtract that number from the total
'3.) keep total - number of 2.)
StrNum8(intCount) = Len(strNames2(intCount))
Pnames(intCount) = Mid(strNames2(intCount), 1, StrNum8(intCount) - 1)

StrNum9(intCount) = Len(strNames1(intCount))
Tnames(intCount) = Mid(strNames1(intCount), 1, StrNum9(intCount) - 1)
If Mid(Tnames(intCount), 1, 1) <> "T" Then
Tnames(intCount) = Mid(Tnames(intCount), 2, StrNum9(intCount))
End If



StrNum4(intCount) = InStr(1, strNames3(intCount), Chr$(11))

StrNum5(intCount) = InStr((StrNum4(intCount) + 1), strNames3(intCount), Chr$(11))
If StrNum5(intCount) = 0 Then
StrNum5(intCount) = InStr((StrNum4(intCount) + 1), strNames3(intCount), vbCr)
End If

StrNum6(intCount) = InStr((StrNum5(intCount) + 1), strNames3(intCount), Chr$(11))
If StrNum6(intCount) = 0 Then
StrNum6(intCount) = InStr((StrNum5(intCount) + 1), strNames3(intCount), vbCr)
End If


StrNum7(intCount) = InStr((StrNum6(intCount) + 1), strNames3(intCount), Chr$(11))
If StrNum7(intCount) = 0 Then
StrNum7(intCount) = InStr((StrNum6(intCount) + 1), strNames3(intCount), vbCr)
End If

If StrNum7(intCount) = StrNum4(intCount) Then
StrNum7(intCount) = 0
End If



Title1(intCount) = Left$((strNames3(intCount)), StrNum4(intCount) - 1)

Title2(intCount) = Mid(strNames3(intCount), StrNum4(intCount) + 1, _
(StrNum5(intCount) - StrNum4(intCount) - 1))

If StrNum6(intCount) <> 0 Then
Title3(intCount) = Mid(strNames3(intCount), StrNum5(intCount) + 1, _
(StrNum6(intCount) - StrNum5(intCount) - 1))
End If

If StrNum7(intCount) <> 0 Then
Title4(intCount) = Mid(strNames3(intCount), StrNum6(intCount) + 1, _
(StrNum7(intCount) - StrNum6(intCount) - 1))
End If


End If

intCount = intCount + 1 'increment the variable to pick up the next instance of title text
Selection.Collapse wdCollapseEnd
'collapse to the end of selection
Wend


LeaveMacro:
'clear word's find/replace object
With Selection.Find
.MatchCase = False
.ClearFormatting
.Replacement.ClearFormatting
End With



'open new Excel workbook
On Error Resume Next
' Set XlApp = GetObject(, "Excel.Application")
' If XlApp Is Nothing Then
Set XlApp = CreateObject("Excel.Application")
If XlApp Is Nothing Then
MsgBox "Could not start Excel"
End
End If
' End If

XlApp.Visible = True

Set XlWb = Workbooks.Add()
Set XlWs = XlWb.Worksheets(1)
XlWs.Cells(1, 1).Value = "Table/Figure #:"
XlWs.Columns("A:A").ColumnWidth = 20
XlWs.Cells(1, 2).Value = "Index #:"
XlWs.Columns("B:B").ColumnWidth = 20
XlWs.Cells(1, 3).Value = "PDS # (Report Name):"
XlWs.Columns("C:C").ColumnWidth = 20
XlWs.Cells(1, 4).Value = "Program Name:"
XlWs.Columns("D:D").ColumnWidth = 20
XlWs.Cells(1, 5).Value = "Category:"
XlWs.Columns("E:E").ColumnWidth = 20
XlWs.Cells(1, 6).Value = "Owner:"
XlWs.Columns("F:G").ColumnWidth = 25
XlWs.Cells(1, 7).Value = "Title1:"
XlWs.Columns("G:G").ColumnWidth = 75
XlWs.Cells(1, 8).Value = "Title2:"
XlWs.Columns("H:H").ColumnWidth = 50
XlWs.Cells(1, 9).Value = "Title3:"
XlWs.Columns("I:I").ColumnWidth = 50
XlWs.Cells(1, 10).Value = "Title4:"
XlWs.Columns("J:J").ColumnWidth = 50
XlWs.Cells(1, 11).Value = "Abbreviations Footnote (if applicable):"
XlWs.Columns("K:K").ColumnWidth = 50
XlWs.Cells(1, 12).Value = "Test Statistic Footnote:"
XlWs.Columns("L:L").ColumnWidth = 20
XlWs.Cells(1, 13).Value = "Population"
XlWs.Columns("M:M").ColumnWidth = 20
XlWs.Cells(1, 14).Value = "Baseline Visits"
XlWs.Columns("N:N").ColumnWidth = 20
XlWs.Cells(1, 15).Value = "Comparison Visits"
XlWs.Columns("O:O").ColumnWidth = 20
XlWs.Cells(1, 16).Value = "Datasets:"
XlWs.Columns("P:P").ColumnWidth = 20
XlWs.Cells(1, 17).Value = "Variables from Datasets:"
XlWs.Columns("Q:Q").ColumnWidth = 50
XlWs.Cells(1, 18).Value = "Derived Variables (including derivations):"
XlWs.Columns("R:R").ColumnWidth = 50
XlWs.Cells(1, 19).Value = "Statistical Analysis (including statistics and model:"
XlWs.Columns("S:S").ColumnWidth = 50
XlWs.Cells(1, 20).Value = "Other Relevant Information, Comments (e.g. dataset restrictions):"
XlWs.Columns("T:T").ColumnWidth = 60
XlWs.Cells(1, 21).Value = "TFL Mock-up:"
XlWs.Columns("U:U").ColumnWidth = 20



With XlWs
.Rows(1).Font.Bold = True
.Rows(1).HorizontalAlignment = xlCenter
End With
For intRows = 1 To intCount - 1
XlApp.Sheets(2).Cells(intRows + 1, 1).Value = strNames3(intRows)
XlWs.Cells(intRows + 1, 1).Value = Tnames(intRows)
XlWs.Cells(intRows + 1, 2).Value = intRows
' XlWs.Cells(intRows + 1, 3).Value = strNames1(intRows)
XlWs.Cells(intRows + 1, 4).Value = strNames2(intRows)
XlWs.Cells(intRows + 1, 7).Value = Title1(intRows)
XlWs.Cells(intRows + 1, 8).Value = Title2(intRows)
XlWs.Cells(intRows + 1, 9).Value = Title3(intRows)
XlWs.Cells(intRows + 1, 10).Value = Title4(intRows)
With XlWs
.Columns(1).HorizontalAlignment = xlCenter
.Columns(2).HorizontalAlignment = xlCenter
.Columns(5).HorizontalAlignment = xlCenter

End With

Next intRows
Unload Me
Exit Sub

ErrorHandler:
MsgBox "Error" & Err.Number & " :" & Error(Err.Number)
'
End Sub


[I]Edited 11-May-06 by geekgirlau. Reason: insert vba tags

[lucas]

If you zip up your file you can upload a larger file.

[fumei]

I am not quite following what you are doing. But if I understand correctly, you want to get the text for the "Tbl Title" style, and the "Fig Title" style, paragraphs.Sub GetTableFigures()
Dim oPara As Word.Paragraph
Dim strStuff() As String
Dim i As Integer
Dim var
For Each oPara In ActiveDocument.Paragraphs()
Select Case oPara.Style
Case "Fig Title"
ReDim Preserve strStuff(i)
strStuff(i) = "Figure text =" & vbTab & oPara.Range.Text
i = i + 1
Case "Tbl Title"
oPara.Range.Select
Selection.MoveEnd unit:=wdParagraph, Count:=1
ReDim Preserve strStuff(i)
strStuff(i) = "Table text =" & vbTab & Selection.Text
i = i + 1
End Select
Next
Documents.Add
For var = 0 To UBound(strStuff)
Selection.TypeText Text:=strStuff(var)
Next
End SubThis will do that. I do not see what you are doing with all the string manipulations - so if you can explain that maybe I can add some other comment. However, if you simply want to GET the text for each of the styles...then you can do so easier.

What the code does:

1. Make a paragraph object
2. Runs through all paragraphs in the document making each one the paragraph object
3. Check for the style of the paragraph object
4 Performs a Select Case on the style. If it is Fig Title style, it takes the text of the paragraph object and adds it to the array. If it is Tbl Title, it selects the paragraph object, extends it to include the NEXT paragraph, then puts that in the array. I added text to identify which style using "Figure text =" and "Table text =" to each item in the array.
5. then to make sure it did it, I simply created a new document and dumped the contents of the array. Obviously this is not what you want to do, i just did that for an example for myself.

So maybe if you explain what you are trying to do with all those string manipulations, I can suggest something further. In the meantime, I hope this helps.

[Quinn]

fumei,
Thanks for helping! I can see what your doing in your code. (although,
it sometimes picks up more text that is not 'Fig Title' or 'Tbl Title'.
try your code on the attachment below.).
Here is what I need to do:
I have to look through a large document and pick up the information in the Table Titles and Figure Titles. I need to put this information into an Excel spreadsheet. I later add some more information (columns) to the spreadsheet, this information was not included in the original document. I send that spreadsheet to one of our teams of writers.

The second part, is that I use the spreadsheet to create tables in Word, one table per page from each row in the spreadsheet. This document of pages is given to our medical writers.
So, for instance, in our last research project, I created a spreadsheet with
175 rows, sent that off, and then created a document of 175 pages of tables and handed that off.
The purpose of all those string manipulations was to break up the information in the Table Title to form specific columns. The spreadsheet and table have to follow a convention.
Quinn