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
New column on top next page or on top same page?
Just now I haven't Visio there. In this archive (http://visio.getbb.ru/download/file.php?id=115) 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
Hello,
just a new column on the same page.
E.g. like you would insert a 2 column table in Word.
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
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
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 (https://msdn.microsoft.com/en-us/vba/visio-vba/articles/layer-delete-method-visio)
Yes you're right.
Didn't see that... :o
Great tool! :)