· Duplicating a page · Fixing the print settings · Set zoom of all page to 'fit to page' |
· Paste as unformatted text · Copy/paste in place · Copy page to doc |
· Create table of contents |
Public Sub CopyPage()
Dim currPage As Visio.Page
Dim newPage As Visio.Page
Dim maxNr As Integer
Dim currBackPage As String
Dim currPageName As String
Dim allShapes As Visio.Selection
Dim groupedShapes As Visio.Shape
' Group all shapes on the current page and copy them to clipboard
ActiveWindow.SelectAll
Set allShapes = ActiveWindow.Selection
Set groupedShapes = allShapes.Group
groupedShapes.Copy visCopyPasteNoTranslate
groupedShapes.Ungroup
' Create the new page
Set currPage = ActivePage
Set newPage = ActiveDocument.Pages.Add
If Not (currPage.Background) Then
'if current page is a background page, don't set index
newPage.Index = currPage.Index + 1
End If
' Create a proper name for the new page
currPageName = currPage.Name
maxNr = Len(currPageName)
If (maxNr > 24) Then
maxNr = 24
End If
newPage.Name = Left(currPageName, maxNr) + " (copy)"
'Paste the grouped shapes
newPage.Paste visCopyPasteNoTranslate
If newPage.Shapes.Count Then
newPage.Shapes.Item(1).Ungroup
End If
ActiveWindow.DeselectAll
End Sub
Public Sub MakeAllA3() Application.ActiveDocument.PaperSize = visPaperSizeA3 Application.ActiveDocument.PrintFitOnPages = True Application.ActiveDocument.PrintLandscape = True Application.ActiveDocument.PrintPagesAcross = 1 Application.ActiveDocument.PrintPagesDown = 1 End Sub
Public Sub FitToPageAll() Dim PageToIndex As Visio.Page Dim curPage As Visio.Page Set curPage = ActivePage ' loop through all the pages you have and set the zoom factor For Each PageToIndex In ActiveDocument.Pages ActiveWindow.Page = ActiveDocument.Pages(PageToIndex.Index).Name ActiveWindow.Zoom = -1 Next ActiveWindow.Page = curPage End Sub
Public Sub PasteAsText() Dim objShps As Visio.Selection Dim obj As Visio.Shape Dim dummy As Visio.Shape Dim oldStyle As String 'get the Selection Set objShps = Visio.ActiveWindow.Selection If (objShps.Count = 1) Then Set obj = objShps(1) oldStyle = obj.TextStyle ' first page the text in a dummy shape and remove style Set dummy = ActiveWindow.Page.DrawRectangle(1, 1, 2, 2) dummy.Characters.Paste dummy.TextStyle = "" 'if text has been selected paste it into the selection ActiveWindow.SelectedText.Text = dummy.Text 'obj.TextStyleKeepFmt = oldStyle dummy.Delete Else ActivePage.PasteSpecial (visPasteText) End If End Sub
Public Sub CopyPageToDoc() Dim currPage As Visio.Page Dim newPage As Visio.Page Dim maxNr As Integer Dim currBackPage As String Dim currPageName As String Dim allShapes As Visio.Selection Dim groupedShapes As Visio.Shape ' Group all shapes on the current page and copy them to clipboard ActiveWindow.SelectAll Set allShapes = ActiveWindow.Selection Set groupedShapes = allShapes.Group groupedShapes.Copy visCopyPasteNoTranslate groupedShapes.Ungroup ActiveWindow.DeselectAll ' Select the document to copy to Dim i As Integer Dim docObj As Visio.Document ufCopyPage.lb_docs.Clear For i = 1 To Documents.Count 'Get next open document Set docObj = Documents.Item(i) 'Add its name to the list box ufCopyPage.lb_docs.AddItem docObj.Name Next i ufCopyPage.Show End Sub
Public Sub copyPageToDoc2(destDocName) 'Get the destination document Set destDocObj = Documents.Item(destDocName) ' Create the new page Set currPage = ActivePage Set newPage = destDocObj.Pages.Add ' Create a proper name for the new page currPageName = currPage.Name newPage.Name = currPageName 'Paste the grouped shapes newPage.Paste visCopyPasteNoTranslate If newPage.Shapes.Count Then newPage.Shapes.Item(1).Ungroup End If ActiveWindow.DeselectAll End Sub
Public Sub CopyNoTranslate() Application.ActiveWindow.Selection.Copy (visCopyPasteNoTranslate) End Sub Public Sub PasteNoTranslate() Application.ActivePage.Paste (visCopyPasteNoTranslate) End Sub
Public Sub CreateTableOfContents() ' creates a shape for each page in the drawing on the first page of the ' drawing then adds a hyperlink to each shape so you can click and go ' to that page Dim TOCEntry As Visio.Shape Dim PageToIndex As Visio.Page Dim X As Integer Dim StartX, StartY, TocWidth As Integer Dim TocLineHeight As Double Dim hlink As Visio.Hyperlink Dim PageCnt As Double ' Set initial position and width and height. Change these values to adjust appearance StartX = 2 StartY = 4 TocWidth = 7.5 TocLineHeight = 0.2 ' 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 ' you may want to refine this and use a top down algorithm with ' something smaller than 1 inch increments. X = PageToIndex.Index If (PageToIndex.Background = False) Then ' draw a rectangle for each page to hold the text Set TOCEntry = ActivePage.DrawRectangle(StartX,StartY+((PageCnt-X+1)* TocLineHeight),StartX+TocWidth, StartY+((PageCnt-X)*TocLineHeight)) ' write the page name in the rectangle TOCEntry.Text = PageToIndex.Name + Chr(9) + Str(X) 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 = "131 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