14.1 Office自动化入门

14.2 复合文档的详细说明

14.3 复合文档的编程

代码清单14.1: 使用OLEObjects来编程创建复合文档

 

代码
'代码清单14.1: 使用OLEObjects来编程创建复合文档

Sub CreateCompoundDocument()
    
Dim rg As Range
    
Dim obj As OLEObject
    
    
'set up a range that will indicate the
    'top left corner of the oleObject
    Set rg = ThisWorkbook.Worksheets(1).Cells(22)
    
    
'Insert oleObject
    Set obj = InsertObject(rg, "C:\testdoc.doc"False)
    
    
'demonstrate that the object was inserted (or not)
    If Not obj Is Nothing Then
        Debug.Print 
"object inserted."
    
Else
        Debug.Print 
"sorry - the object could not be inserted."
    
End
    
    
'clean up
    Set obj = Nothing
    
Set rg = Nothing
End Sub

Function InsertObject(rgTopLeft As Range, sFile As String, bLink As BooleanAs OLEObject
    
Dim obj As OLEObject
    
    
On Error GoTo ErrHandler
    
    
'Insert the object
    Set obj = rgTopLeft.Parent.OLEObjects.Add(Filename:=sFile, link:=bLink)
    
    
'don't specify these in the add method
    'above - it causes an error.
    obj.Top = rgTopLeft.Top
    obj.Left 
= rgTopLeft.Left
    
    
'return a reference to the inserted oleObject
    Set InsetObject = obj
    
Exit Function
ErrHandler:
    
    
'tarter sauce! an error occurred.
    Debug.Print Err.Description
    
Set InsertObject = Nothing
End Function

 

 

14.4 OLE很好;自动化更好

代码清单14.2: 先绑定与后绑定

 

代码
'代码清单14.2: 先绑定与后绑定

Sub WordEarlyBound()
    
Dim wd As Word.Application
    
Dim doc As Word.Document
    
    
'create new instance of word
    Set wd = New Word.Application
    
    
'add a new document
    Set doc = wd.Documents.Add
    
    
'save & close the document
    doc.SaveAs "C:\testdoc1.doc"
    doc.Close
    
    
'clean up
    Set doc = Nothing
    
Set wd = Nothing
End Sub

Sub WordLateBound()
    
Dim wd As Object
    
Dim doc As Object
    
    
'create new instance of word
    Set wd = CreateObject(" Word.Application")
    
    
'add a new document
    Set doc = wd.Documents.Add
    
    
'save & close the document
    doc.SaveAs "C:\testdoc2.doc"
    doc.Close
    
    
'clean up
    Set doc = Nothing
    
Set wd = Nothing
End Sub

 

 

代码清单14.3: 在Excel中自动创建PowerPoint陈述

 

代码
'代码清单14.3: 在Excel中自动创建PowerPoint陈述

Sub CreatePresentation()
    
Dim ppt As PowerPoint.Application
    
Dim pres As PowerPoint.Presentation
    
Dim sSaveAs As String
    
Dim ws As Worksheet
    
Dim chrt As Chart
    
Dim nSlide As Integer
    
    
On Error GoTo ErrHandler
    
    
Set ws = ThisWorkbook.Worksheets("Reports")
    
Set ppt = New PowerPoint.Application    
    
Set pres = ppt.Presentations.Add
    
    pres.ApplyTemplate 
= "C:\Program Files\Microsoft Office\Templates\Presentation Designs\Maple.gif"
    
With pres.Slides.AddSlide(1, ppLayoutTitle)
        .Shapes(
1).TextFrame.TextRange.Text = "October Sales Analysis"
        .Shapes(
2).TextFrame.TextRange.Text = "11/5/2003"
    
End With
    
    
'copy data
    CopyDataRange pres, ws.Range("Sales_Summary"), 22
    CopyChart pres, ws.ChartObjects(
1).Chart, 31
    CopyDataRange pres, ws.Range(
"Top_Five"), 42
    
    
'save & close the presentation file
    sSaveAs = GetSaveAsName("Save As")
    
If sSaveAs <> "False" Then
        pres.SaveAs sSaveAs
    
End If
    pres.Close

ExitPoint:
    Application.CutCopyMode 
= False
    
Set chrt = Nothing
    
Set ws = Nothing
    
Set pres = Nothing
    
Set ppt = Nothing
    
Exit Sub        
ErrHandler:
    
MsgBox "sorry the following error has occurred: " & vbCrLf & vbCrLf & Err.Description, vbOKOnly
    
Resume ExitPoint
End Sub

Sub CopyDataRange(pres As PowerPoint.Presentation, rg As Range, nSlide As Integer, dScaleFactor As Double)
    
'copy range to clipboard
    rg.Copy
    
    
'add new blank slide
    pres.Slides.AddSlide nSlide, ppLayoutBlank
    
    
'paste the range to the slide
    pres.Slides(nSlide).Shapes.PasteSpecial ppPasteOLEObject
    
    
'scale the pasted object in powerPoint
    pres.Slides(nSlide).Shapes(1).ScaleHeight dScaleFactor, msoTrue
    pres.Slides(nSlide).Shapes(
1).ScaleWidth dScaleFactor, msoTrue
    
    
'center horizontally & vertically
    'might be a good idea to move this outside this procedure
    'so you have more control over whether this happens or not
    CenterVertically pres.Slides(nSlide).Shapes(1)
    CenterHorizontally pres.Slides(nSlide).Shapes(
1)
End Sub

Sub CopyChart(pres As PowerPoint.Presentation, chrt As Chart, nSlide As Integer, dScaleFactor As Double)
    
'copy chart to clipboard as a picture
    chrt.CopyPicture xlScreen
    
    
'add slide
    pres.Slides.AddSlide nSlide, ppLayoutBlank
    
    
'copy chart to powerPoint
    pres.Slides(nSlide).Shapes.PasteSpecial ppPasteDefault
    
    
'scale picture
    pres.Slides(nSlide).Shapes(1).ScaleHeight dScaleFactor, msoTrue
    pres.Slides(nSlide).Shapes(
1).ScaleWidth dScaleFactor, msoTrue
    
    
'center horizontally & vertically
    'might be a good idea to move this outside this procedure
    'so you have more control over whether this happens or not
    CenterVertically pres.Slides(nSlide).Shapes(1)
    CenterHorizontally pres.Slides(nSlide).Shapes(
1)
End Sub

Function GetSaveAsName(sTitle As StringAs String
    
Dim sFilter As String
    sFilter 
= "Presentation (*.ppt),*.ppt"    
    GetSaveAsName 
= Application.GetSaveAsFilename(filefilter:=sFilter, Title:=sTitle)    
End Function

Sub CenterVertically(sl As PowerPoint.Slide, sh As PowerPoint.Shape)
    
Dim lHeight As Long    
    lHeight 
= sl.Parent.PageSetup.SlideHeight
    sh.Top 
= (lHeight - sh.Height) / 2
End Sub

Sub CenterHorizontally(sl As PowerPoint.Slide, sh As PowerPoint.Shape)
    
Dim lWidth As Long    
    lWidth 
= sl.Parent.PageSetup.SlideWidth
    sh.Left 
= (lWidth - sh.Width) / 2
End Sub