Hi,

I tried to post through the MSDN groups yesterday but I don't think it went.
I finally got my OE working.  :)

I have a routine that I use that performs the following:

Routine runs on Document_Open()
Prompts user to select Publisher file to Export
Opens file, looping through each page
Powerpoint instance is created from blank template (temp.pot)
Each page is saved as a picture (SavePictureAs) temporary
Each picture is inserted into PPT slide, fit to slide size
New slide is inserted in PPT presentation
Temporary picture is deleted (Kill)
PPT presentation is saved to Desktop (user input name from inputbox, will
default to Imported Publisher file name)

The problem comes into play when I have say a 3 page Document.  (Btw, these
will all be Brochures.)  Page 1 will save as a picture just fine, but Page 2
will save it's picture as Page 2 AND Page 3.  So it doesn't help for me to
loop/iterate through each page.

The question I have is:  Is there any way to get each individual page to
save as a picture without it's counterpart page?

I realize I don't know the Publisher Object Model very well, and I
appreciate the input of anybody.  Thanks for your time.

Code:

Option Explicit

Public Const NL As String = vbNewLine
Public Const DNL As String = vbNewLine & vbNewLine

Sub PPTcreate()
   If CLng(Application.Version) < 11 Then
       MsgBox "You need Publisher 2003 or later to run this.", "Bad
Version"
       Exit Sub
   End If
'** Reference made to Microsoft PowerPoint 11.0 Object Library
'** Using Early Binding
   Dim PPTapp As New PowerPoint.Application
   Dim PPTpres As PowerPoint.Presentation
   Dim PPTslide As PowerPoint.Slide
   Dim newSlide As PowerPoint.Slide
   Dim PPTpath As String, strName As String, ToCDpath As String
   Dim thisFile As Document, targetFile As Document, pptFname As String
   Dim pg As Page, pptH As Long, pptW As Long, pptN As String
   Dim lngPages As Long, lngPg As Long, i As Long
   Dim dlgSaveAs As FileDialog, myMsg As VbMsgBoxResult
   Dim strFile As String, isOpen As Boolean
   myMsg = MsgBox("Please select the Publisher file you wish to" & NL & _
       "Import into a PowerPoint Presentation." & DNL & _
       "Note this Template will close upon completion.", _
       vbOKCancel, "Pub File to Export")
   If myMsg = 2 Then GoTo theEnd
   Set dlgSaveAs = Application.FileDialog(msoFileDialogOpen)
   dlgSaveAs.Show
   On Error Resume Next
   strFile = dlgSaveAs.SelectedItems(1)
   If Err Then GoTo theEnd
   If Right(strFile, 4) <> ".pub" Then
       MsgBox "You must only try to Export a Publisher file!", _
           vbCritical, "Publisher Only"
       GoTo theEnd
   End If
   On Error GoTo 0
   Application.ScreenUpdating = False
   On Error Resume Next
   Set targetFile = Application.Open(strFile)
   If Err Then
       Set targetFile = Application.Documents(Right(strFile, _
           Len(strFile) - InStrRev(strFile, "\")))
       Err.Clear
   End If
   pptN = Left(targetFile.Name, Len(targetFile.Name) - 4)
   isOpen = True
   Set thisFile = ThisDocument
   lngPages = targetFile.Pages.Count
   Set PPTapp = CreateObject("PowerPoint.Application")
   PPTapp.DisplayAlerts = ppAlertsNone
   PPTpath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") &
_
       Application.PathSeparator & "PowerPoint Templates" &
Application.PathSeparator
   ToCDpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
       Application.PathSeparator
   PPTapp.Visible = True
   Set PPTpres = PPTapp.Presentations.Open(PPTpath & "test.pot")
   pptFname = Left(PPTpres.FullName, Len(PPTpres.FullName) - 4) & ".PPT"
   With PPTpres.PageSetup
       .SlideSize = ppSlideSizeOnScreen
       .FirstSlideNumber = 1
       .SlideOrientation = msoOrientationVertical
       .NotesOrientation = msoOrientationVertical
   End With
   For Each pg In targetFile.Pages
       i = i + 1
       pg.SaveAsPicture ("C:\Temp\temp" & i & ".JPG")
       With PPTpres.Slides(i).Shapes
           .AddPicture("C:\Temp\temp" & i & ".JPG", _
               LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=54, _
               Top:=-125, Width:=612, Height:=792).Select
           With .Range
               pptH = PPTpres.PageSetup.SlideHeight
               pptW = PPTpres.PageSetup.SlideWidth
               .ScaleHeight 1, msoFalse
               .ScaleWidth 1, msoFalse
               .Left = 1
               .Top = 1
               .Width = pptW
               .Height = pptH
           End With
       End With
       Set newSlide = PPTpres.Slides.Add(PPTpres.Slides.Count + 1,
ppLayoutText)
       newSlide.Select
       Set newSlide = Nothing
       Kill "C:\Temp\temp" & i & ".JPG"
   Next
   PPTpres.Slides(PPTpres.Slides.Count).Delete 'blank/last slide
   targetFile.Close
   targetFile.Application.Quit
pptNameStart:
   Application.ScreenUpdating = True
   PPTapp.WindowState = ppWindowMinimized
   Application.ActiveWindow.Activate
   strName = InputBox("Enter a name for the PowerPoint Presentation:" & DNL
& _
       "(Do not include extension)", _
       "PPT Name", pptN)
   PPTpres.SaveAs ToCDpath & strName & ".PPT"
   On Error GoTo pptNameStart
   PPTpres.Close
   PPTapp.DisplayAlerts = ppAlertsAll
   PPTapp.Quit
   On Error GoTo 0
theEnd:
   If isOpen = True Then
       MsgBox "Your file has been saved to:" & DNL & pptFname & NL & DNL &
_
           "To Package for CD:" & DNL & _
           "    * Open file from above path" & NL & _
           "    * Select File (menu)" & NL & _
           "    * Select Package to CD..." & NL & _
           "    * Pick either Folder or CD" & NL & DNL & _
           "Note that you must have a CD/DVD burner to perform this
function.", _
           vbOKOnly + vbInformation, "Package Instructions"
   End If
   Application.ScreenUpdating = True
   On Error Resume Next
   Set PPTapp = Nothing
   Set PPTpres = Nothing
   Set PPTslide = Nothing
   Set thisFile = Nothing
End Sub

Regards,
Zack Barresse