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