Table of Contents with Text from textbox

[Klint]

Hi Guys,

New to the forum, and very new to VBA.   

I want to create a textbox om the first page, containing information from alle other pages. (not background)
I have found this VBA script
http://steve.turbek.com/articles/2007/04/automatically-create-table-of-contents.html

Code Select Expand

Sub table_of_contents_creator()
'this macro creates a table of contents in a visio document by
'going through the pages in the document and adds the page number and page title

'by stephen turbek s@stephenturbek.com
'written for use in microsoft visio 2003 SP1

'adapted from http://www.greenonions.com/tocscript
'I added allowing user to select a text box and replace the contents, rather than build lots of little boxes
'this way you can style the text easily, and simply replace the contents when you update the doc
'note: this is my first VB script


' define a shape to use for the Table of Contents (TOC)
Dim TOCEntry As Visio.Shape


'get selection
Dim selectedShapes As Selection
Set selectedShapes = ActiveWindow.Selection


'is any shape selected to put the ToC in?
If selectedShapes.Count > 0 Then
'take the selected shape to put the table of contents in
Set TOCEntry = ActiveWindow.Selection.Item(1)
Else
'nothing is selected, create a shape
Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, 1, 7.5, 10)

TOCEntry.Cells("VerticalAlign").Formula = "0" 'make text box top vertically aligned
TOCEntry.Cells("Para.HorzAlign").Formula = visHorzLeft 'make text box left aligned


End If

'clear out the shape's text
TOCEntry.Text = ""

'a variable to hold the page array
Dim PageToIndex As Visio.Page

' loop through all the pages
For Each PageToIndex In Application.ActiveDocument.Pages

'exit when it hits the first background page (don't want those in the ToC)
If PageToIndex.Background Then Exit For

'append the page number, a tab, the page name, and a return to the ToC text shape
TOCEntry.Text = TOCEntry.Text + CStr(PageToIndex.Index) + vbTab + PageToIndex.Name + vbNewLine

Next

End Sub

It works like a charm, but i would like to add som more information.
On all pages i have a Textblock, which i have named Emne (Danish for Subject) in the shapename
This textbox contains different texts on all the pages, and i would like to add the text string after the corrosponding pagename (PageToIndex.Name)

[Surrogate]

Please try and

Code Select Expand

PageToIndex.Shapes("Enme").Text

[Klint]

Hi Surrogate,

It returns the error Object not found, and marks the lige where i inserted your suggestion.

Code Select Expand

TOCEntry.Text = TOCEntry.Text + CStr(PageToIndex.Index) + vbTab + PageToIndex.Name + vbTab + PageToIndex.Shapes("Emne").Text + vbNewLine


[Surrogate]

Oh, you use Danish locale there is may be local/universal name problem.
Name and NameU article.

[Klint]

I managed to get text readout from the textbox, when i use the following command in the Immediate window:
Visio.ActivePage.Shapes.Item("Emne").Text

But when i insert the part in my line, nothing happens:

Code Select Expand

TOCEntry.Text = TOCEntry.Text + CStr(PageToIndex.Index) + vbTab + PageToIndex.Name + vbTab + Visio.ActivePage.Shapes.Item("Emne").Text + vbNewLine
I don't get any errors, but the script dosen't do anything but clears any old text in my textbox.

I'm guessing that something goes wrong with the loop through the pages, and the ActivePage part, but i'm just guessing..

Any Ideas?

[Klint]

I managed to get the main script working.
The Script now loops through all the pages and collect the text from shapes named "Emne"

Code Select Expand

Sub Indholdsfortegnelse()
'this macro creates a table of contents in a visio document by
'going through the pages in the document and adds the page number and page title

'Original by stephen turbek s@stephenturbek.com

'Modified by Simon Klint s.klint@gmail.com
'Modified so that the TOC includes text from a shape on each page


' define a shape to use for the Table of Contents (TOC)
Dim TOCEntry As Visio.Shape

Dim selectedShapes As Selection
Set selectedShapes = ActiveWindow.Selection

'is any shape selected to put the ToC in?
If selectedShapes.Count > 0 Then
    'take the selected shape to put the table of contents in
    Set TOCEntry = ActiveWindow.Selection.Item(1)
Else
    'nothing is selected, create a shape
    Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, 1, 7.5, 10)
   
    TOCEntry.Cells("VerticalAlign").Formula = "0"  'make text box top vertically aligned
    TOCEntry.Cells("Para.HorzAlign").Formula = visHorzLeft 'make text box left aligned
 
End If


'clear out the shape's text
TOCEntry.Text = ""

'a variable to hold the page array
Dim TextBlock As Visio.Shapes

'a variable used to loop through the pages
Dim PagsObj As Visio.Pages
Set PagsObj = ActiveDocument.Pages

Dim PagObj As Visio.Page
Dim Subject As String


For Each PagObj In PagsObj
ActiveWindow.Page = PagObj.Name

Set TextBlock = ActivePage.Shapes

    If PagObj.Background Then Exit For
   
        On Error GoTo NoSubject 'If Subject shape not found, create TOC without subject
               
        Subject = TextBlock.Item("Emne").Text
       
        On Error GoTo NoSubject 'If Subject shape not found, create TOC without subject
       
        TOCEntry.Text = TOCEntry.Text + CStr(PagObj.Index) + vbTab + PagObj.Name + " - " + Subject + vbNewLine
           
        GoTo SubjectFound 'Subject found, so Skip the TOC without Subject

NoSubject:
        'Create TOC without Subject field
        TOCEntry.Text = TOCEntry.Text + CStr(PagObj.Index) + vbTab + PagObj.Name + vbNewLine
        Subject = ""
SubjectFound:

Next PagObj

ActiveWindow.Page = ActiveDocument.Pages(1) 'Set active page back to frontpage

End Sub


My problem now is that i might not have a shape called "Emne" on all pages.
The

Code Select Expand

On Error GoTo NoSubject only works first time the script dosent't find a shape.
The second time i get to a page without a shape called "Emne" i get the Objectname not found error, and the script stops.

Any ideas why this happens?

I would like to perform a check to see if the shape exists on the active page, but i'm kinda stuck on that.

[Klint]

Yeah!! I've go it working now. 

Code Select Expand

Sub Indholdsfortegnelse()
'this macro creates a table of contents in a visio document by
'going through the pages in the document and adds the page number and page title

'Original by stephen turbek s@stephenturbek.com

'Modified by Simon Klint s.klint@gmail.com
'Modified so that the TOC includes text from a shape on each page


' define a shape to use for the Table of Contents (TOC)
Dim TOCEntry As Visio.Shape

Dim selectedShapes As Selection
Set selectedShapes = ActiveWindow.Selection

'is any shape selected to put the ToC in?
If selectedShapes.Count > 0 Then
    'take the selected shape to put the table of contents in
    Set TOCEntry = ActiveWindow.Selection.Item(1)
Else
    'nothing is selected, create a shape
    Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, 1, 7.5, 10)
   
    TOCEntry.Cells("VerticalAlign").Formula = "0"  'make text box top vertically aligned
    TOCEntry.Cells("Para.HorzAlign").Formula = visHorzLeft 'make text box left aligned
 
End If


'clear out the shape's text
TOCEntry.Text = ""

'a variable to hold the page array
Dim TextBlock As Visio.Shapes
Dim Shape As Visio.Shape

'a variable used to loop through the pages
Dim PagsObj As Visio.Pages
Set PagsObj = ActiveDocument.Pages

Dim PagObj As Visio.Page
Dim Subject As String


For Each PagObj In PagsObj
ActiveWindow.Page = PagObj.Name

Set TextBlock = ActivePage.Shapes

    If PagObj.Background Then Exit For
   
        'On Error GoTo NoSubject 'If Subject shape not found, create TOC without subject
        'Search for the "Emne" Shape in the active document
        For Each Shape In Visio.ActivePage.Shapes
           
            If Shape.Name = "Emne" Then
                Subject = TextBlock.Item("Emne").Text
                GoTo SubjectOk
            End If
           
        Next
       
    GoTo NoSubject

SubjectOk:
        TOCEntry.Text = TOCEntry.Text + CStr(PagObj.Index) + vbTab + PagObj.Name + " - " + Subject + vbNewLine
           
        GoTo SubjectFound 'Subject found, so Skip the TOC without Subject

NoSubject:
        'Create TOC without Subject field
        TOCEntry.Text = TOCEntry.Text + CStr(PagObj.Index) + vbTab + PagObj.Name + vbNewLine
        Subject = ""

SubjectFound:

Next PagObj

ActiveWindow.Page = ActiveDocument.Pages(1) 'Set active page back to frontpage

End Sub