if you only need a single page, consider cut and paste metafile format.
If you need more pages, you might consider a macro similar to this
al
'*********************************************************************
'*********************************************************************
'
' these are the powerpoint functions
' This is setup to copy the components from foreground pages
'
'*********************************************************************
'*********************************************************************
Public Sub subGeneratePowerPoint()
Dim visDocument As Visio.Document
Dim visPage As Visio.Page
Dim ppApp As PowerPoint.Application
Dim ppSlide As PowerPoint.Slide
Dim iObjCtr As Integer
Dim iConCtr As Integer
Dim iPagCtr As Integer
Dim strForeground As String
Dim strBackground As String
Dim shpGroup As Visio.Shape
Const MAX_SLIDES As Long = 250
Const DEFAULT_AUTO_LAYOUT As Long = ppLayoutBlank
Dim lLastSlide As Long
lLastSlide = 1
Dim lToCreate As Long
lToCreate = 10
Dim lResult As Long
Dim Continue As Boolean
Dim strResult As String
On Error GoTo powerpoint_err
Err.Clear
Set visDocument = Visio.ActiveDocument
' start powerpoint
Set ppApp = New PowerPoint.Application
' make it visible
ppApp.Visible = True
' create the presentation
Dim ppPres As PowerPoint.Presentation
Set ppPres = ppApp.Presentations.Add(msoTrue)
lLastSlide = ppPres.Slides.Count
'first we create the pages in the presentation
For iPagCtr = 1 To visDocument.Pages.Count
' we dont want to include the background slides
If visDocument.Pages(iPagCtr).Background = False Then
lLastSlide = lLastSlide + 1
ppPres.Slides.Add lLastSlide, ppLayoutBlank
If Err.Number <> 0 Then
strResult = "Unable to add new slides " &
Err.Description
MsgBox strResult, vbCritical, "Error Adding Slides"
End
End If ' test for slide being created
End If ' test for background
Next iPagCtr
' now we populate the pages in the presentation
For iPagCtr = 1 To visDocument.Pages.Count
' Debug.Print "powerpoint page " & iPagCtr
strForeground = ""
strBackground = ""
If visDocument.Pages(iPagCtr).Background = False Then
' move page to active window
strForeground = visDocument.Pages(iPagCtr).Name
'If Not (visDocument.Pages(iPagCtr).BackPage Is Nothing)
Then
' strBackground = visDocument.Pages(iPagCtr).BackPage
' we can add code here to add background to the slide
' ActiveWindow.Page = strBackground
' but not today
'Else
' strBackground = "NoBackground"
'End If
ActiveWindow.Page = strForeground
ActiveWindow.SelectAll
ActiveWindow.Group
Set shpGroup = ActivePage.Shapes.item(ActivePage.Shapes.Count)
' Debug.Print "powerpoint objects " & ActivePage.Shapes.Count
' copy selected items to clipboard
ActiveWindow.Copy
' Debug.Print "copied"
' Paste Visio drawing from the clipboard to Powerpoint correct
slide
ppPres.Slides.item(iPagCtr).Shapes.Paste
' now paste the page name into the slides footer as a label
ppPres.Slides.item(iPagCtr).HeadersFooters.Footer.Text =
strForeground
DoEvents
' Debug.Print "pasted"
' now let's ungroup them
shpGroup.Ungroup
' Debug.Print "ungrouped"
' deselect the objects so we dont get confused
ActiveWindow.DeselectAll
' give the system back some time to get things done
End If
DoEvents
Next iPagCtr
powerpoint_exit:
Exit Sub
powerpoint_err:
If Err <> 0 Then
Debug.Print "Error in powerpoint " & Err & " " & Err.Description
Err.Clear
Resume Next
End If
End Sub
