|
· Duplicating a page · Fixing the print settings · Set zoom of all page to 'fit to page' |
· Paste as unformatted text · Copy page to doc |
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