Z
Zack Barresse
Hello,
I have some code which takes a specified Publisher File (from the FileDialog
box) and takes each page performing specific tasks ...
Copies as picture to temporary folder.
Adds picture to PowerPoint slide.
Kill's temporary picture.
Prompts for PPT presentation name (via InputBox).
PPT file will always be saved to the desktop.
PPT file generated from a template kept in "MyDocuments\PowerPoint
Templates\" folder.
Early Binding to PowerPoint 11.0 must be made.
Code is as follows:
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
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
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
' GoTo theEnd
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:", "PPT
Name", "Pres1")
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
If I run the procedure with a Document with 3 pages, I get 3 slides. The
problem is when I make use of the (Page) "SaveAsPicture" method it will save
the Brochure pages 2 and 3 as a single image. Is there a way to seperate
these images?
Also, I'm having issues quitting the current Application. With my VBE
(Document) locked, I can Application.Quit and it is like I opened new
(password is needed to view Code Modules, but file remains open. Any ideas?
Searched the web, but alas, there isn't much on Publisher VBA. The best
resource is the MSDN and if you don't know what you're looking for it can be
a mess. I appreciate any help offered here.
Thank for your time.
I have some code which takes a specified Publisher File (from the FileDialog
box) and takes each page performing specific tasks ...
Copies as picture to temporary folder.
Adds picture to PowerPoint slide.
Kill's temporary picture.
Prompts for PPT presentation name (via InputBox).
PPT file will always be saved to the desktop.
PPT file generated from a template kept in "MyDocuments\PowerPoint
Templates\" folder.
Early Binding to PowerPoint 11.0 must be made.
Code is as follows:
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
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
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
' GoTo theEnd
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:", "PPT
Name", "Pres1")
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
If I run the procedure with a Document with 3 pages, I get 3 slides. The
problem is when I make use of the (Page) "SaveAsPicture" method it will save
the Brochure pages 2 and 3 as a single image. Is there a way to seperate
these images?
Also, I'm having issues quitting the current Application. With my VBE
(Document) locked, I can Application.Quit and it is like I opened new
(password is needed to view Code Modules, but file remains open. Any ideas?
Searched the web, but alas, there isn't much on Publisher VBA. The best
resource is the MSDN and if you don't know what you're looking for it can be
a mess. I appreciate any help offered here.
Thank for your time.