第14章 与其他应用程序的集成

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( 2 ,  2 )
    
     ' 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   Boolean )  As  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 " ),  2 ,  2
    CopyChart pres, ws.ChartObjects( 1 ).Chart,  3 ,  1
    CopyDataRange pres, ws.Range( " Top_Five " ),  4 ,  2
    
     ' 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   String )  As   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