2 Columns in table of contents

Started by breital, February 22, 2018, 06:24:24 AM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

breital

Hello guys :)

I am currently trying to program an 'intelligent' table of contents.
The macro counts the pages and lists them up together with the pageNo.

To enable also a higher number of pages I tried to make the macro noticing when it reaches the top of the page
and then skip to the right and start a new column.
Unfortunately I have not that much experience and don't get further :|

Could you take a look at my code and give me some advices/help pls? :)




Private Sub cmd_1_Click()

Dim PageObj As Visio.Page
Dim myShape As Visio.Shape
Dim CellObj As Visio.Cell
Dim PosY As Double
Dim PosX1 As Double
Dim PosX2 As Double
Dim PageCnt As Double
Dim PageNr As Double

PageCnt = 0
For Each PageObj In ActiveDocument.Pages

If PageObj.Background = False Then PageCnt = PageCnt + 1
Next

For Each PageObj In ActiveDocument.Pages

If PageObj.Background = False Then

PageNr = PageNr + 1
PosY = (PageCnt - PageObj.Index) / 4 + 0.5    ' define PosY
   
     
     
     If PosY < 20 Then PosX1 = 0.8: PosX2 = 3.5 Else         ' shall check if PosY is higher than page edge
       PosX1 = 5.8: PosX2 = 8.5                              ' if yes start a new column with other X-Pos.
     
 
Set myShape = ActiveDocument.Pages(1).DrawRectangle(PosX1, PosY + 0.01, PosX2, PosY + 0.2) 'Pos in inch corner 1: 1in/PosY  and Ecke 2: 4in/PosY + 025 in

myShape.Text = "  " & PageNr & vbTab & PageObj.Name
myShape.CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "0"


Set CellObj = myShape.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick)  'Shape property -> hyperlink with double click
CellObj.Formula = "GOTOPAGE(""" + PageObj.Name + """)"

End If
Next



Surrogate

New column on top next page or on top same page?

Just now I haven't Visio there. In this archive you can find xls workbook and Visio document.
In Visio you can find macro, which fill bill of materials from excel to Visio.
If row height don't allow place new row at page, code add new page with table header and start add new rows on this page

breital

Hello,

just a new column on the same page.
E.g. like you would insert a 2 column table in Word.

metuemre

Below is the code that I use to create table of contents. This code will create TOC on Page-2, put 48 rows in a column and if the page number is above 48 it will create a new column. It also add hyperlinks to each cell for navigation to the related page. These hyperlinks are also useful when you print to pdf.

Note that page size is A2 (594 mm x 420 mm), orientation is landscape and visio is in metric units in my environment. You can play with numbers in the formulas to fit them to your application.

Public Sub CreateTableOfContents()

On Error Resume Next

Dim TOCEntry, visshp As Visio.Shape
Dim PageToIndex, pg As Visio.Page
Dim Indx As Integer
Dim hlink As Visio.Hyperlink
Dim PageCnt As Double
Dim vsoLayers As Visio.Layers
Dim vsoLayer As Visio.Layer

Set pg = ActiveDocument.Pages("Page-2")
ActiveWindow.Page = pg.name
Set vsoLayers = pg.Layers
For i = 0 To vsoLayers.count
    If vsoLayers(i).name = "TOC" Then
        vsoLayers(i).Delete (1)
    End If
Next
Set vsoLayer = Nothing
Set vsoLayer = vsoLayers.Add("TOC")

' Count all foreground pages
PageCnt = 0
For Each PageObj In ActiveDocument.Pages
    If PageObj.background = False Then PageCnt = PageCnt + 1
Next

' loop through all the pages you have
For Each PageToIndex In Application.ActiveDocument.Pages
 
  Indx = PageToIndex.Index
   
    If (PageToIndex.background = False) And Not (Left(PageToIndex.name, 8) = "CrossRef") Then
        If Indx < 49 Then
            ' draw a rectangle for each page to hold the text
            Set TOCEntry = ActivePage.DrawRectangle(5.311024, 11.003937, 11.307087, 10.748031)
            TOCEntry.Cells("PinX").Result("mm") = 120
            TOCEntry.Cells("PinY").Result("mm") = 400 - (Indx * 6.35)
        ElseIf (49 <= Indx) And (Indx < 97) Then
            Set TOCEntry = ActivePage.DrawRectangle(5.311024, 11.003937, 11.307087, 10.748031)
            TOCEntry.Cells("PinX").Result("mm") = 300
            TOCEntry.Cells("PinY").Result("mm") = 400 - ((Indx - 48) * 6.35)
        Else
            Set TOCEntry = ActivePage.DrawRectangle(5.311024, 11.003937, 11.307087, 10.748031)
            TOCEntry.Cells("PinX").Result("mm") = 480
            TOCEntry.Cells("PinY").Result("mm") = 400 - ((Indx - 96) * 6.35)
        End If
            vsoLayer.Add TOCEntry, 1
            ' write the page name in the rectangle
            TOCEntry.text = Format(str(Indx), "00") + Chr(9) + PageToIndex.Shapes("txtProjectTitle").text
            TOCEntry.TextStyle = "Normal"
            TOCEntry.LineStyle = "Text Only"
            TOCEntry.FillStyle = "Text Only"
            TOCEntry.CellsSRC(visSectionParagraph, 0, visHorzAlign).FormulaU = "0"
           
            ' add tab stops
            TOCEntry.RowType(visSectionTab, visRowTab) = VisRowTags.visTagTab10
            TOCEntry.CellsSRC(visSectionTab, 0, visTabStopCount).FormulaU = "1"
            TOCEntry.CellsSRC(visSectionTab, 0, visTabPos).FormulaU = "145 mm"
            TOCEntry.CellsSRC(visSectionTab, 0, visTabAlign).FormulaU = "2"
             
            ' need to create a handle to add the hyperlink
            Set hlink = TOCEntry.AddHyperlink
   
            ' add a description
            hlink.Description = PageToIndex.name
   
            ' add the page name as an address
            hlink.SubAddress = PageToIndex.name
           
    End If
   
Next

End Sub

breital

Great! Thank You!

After some adjustments the code works perfectly now!
So now there is only some small tuning left.
E.g. I try to make the code deleting all shapes before creating a new TOC.
And I try to add a reminder that pops up before closing the file :)

Greets,
breital

metuemre

Code actually deletes previous TOC shapes before creating new ones with Layer.Delete method

https://msdn.microsoft.com/en-us/vba/visio-vba/articles/layer-delete-method-visio


breital

Yes you're right.
Didn't see that... :o

Great tool! :)