香港新浪網 MySinaBlog
« 上一篇 | 下一篇 »
Emily | 27th Apr 2006, 21:35 PM | Office Application | (2122 Reads)

Create a Powerpoint pps file

Orginial Link

 

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 27/4/2006 21:31
' Author    : BY xld , orginial posted in http://www.vbaexpress.com
' Purpose   : Create a Powerpoint pps file
'---------------------------------------------------------------------------------------
' Set reference to Micrsoft Powerpoint 11.0 Object Library
' Tested in Office 2003

Sub RunCreatePPS()
    CreatePPS ActiveWorkbook, "A1:L21", "D:powerpointSlide.pps"
End Sub

 

Function CreatePPS(ByVal Book As Workbook, _
    ByVal TheRange As String, _
    ByVal FileName As String)
    Dim appPP As PowerPoint.Application
    Dim PP_Presentation As PowerPoint.Presentation
    Dim PP_Slide As PowerPoint.Slide
    Dim sh As Worksheet
    
    Set appPP = CreateObject("Powerpoint.Application")
    appPP.Visible = True
    Set PP_Presentation = appPP.Presentations.Add
    
    For Each sh In Book.Worksheets
        
        If Application.CountA(sh.Range(TheRange)) > 0 Then
            Set PP_Slide = PP_Presentation.Slides.Add(1, ppLayoutBlank)
            sh.Range(TheRange).CopyPicture Appearance:=xlScreen, Format:=xlPicture
            
            With PP_Slide.Shapes.Paste
                .Align msoAlignCenters, msoTrue
                .Align msoAlignMiddles, msoTrue
            End With
         End If
     Next sh
    With PP_Presentation
        .SaveAs FileName
        .Close
    End With
    
    appPP.Quit
    Set PP_Slide = Nothing
    Set PP_Presentation = Nothing
    Set appPP = Nothing
End Function

 '

mySinaBlog 不支援斜線,斜線現用全形\取代 ,請改回。