Z
zackb
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
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