PPT自动生成大纲宏

Dim strFileName As String
' Both I & J are used as counters
Dim I As Integer
Dim J As Integer
' Working on the active presentation.
   With ActivePresentation
      'Display the input box with the default 'Titles.Txt'
      strFileName = InputBox("Enter a filename to export slide titles", "Provide filename...", "Titles.txt")
'Check if the user has pressed Cancel (Inputbox returns a zero length string)
If strFileName = "" Then
    Exit Sub
End If

' Do some good housekeeping and check for the existence of the file.
' Ask the user for further directions in case it does. : )
If Dir(.Path & "\" & strFileName)  "" Then
    If MsgBox(strFileName & " already exists. Overwrite it?", _
                vbQuestion + vbYesNo, "Warning") = vbNo Then
        Exit Sub
    End If
End If

' Open the file for exporting the slide titles. File is created in the same folder as the open presentation.
' If the Presentation is a new one (No path) then it will get created in the Root Folder
Open .Path & "\" & strFileName For Output As #1
For I = 1 To .Slides.Count

   ' Returns TRUE if there is a TitlePlaceholder
   If .Slides(I).Shapes.HasTitle Then
   ' Now loop thru the PlaceHolders and pick the text from the TitlePlaceHolder
       For J = 1 To .Slides(I).Shapes.Placeholders.Count
           With .Slides(I).Shapes.Placeholders.Item(J)
           If .PlaceholderFormat.Type = ppPlaceholderTitle Then
               ' Just inserted for debugging purposes...
              Debug.Print .TextFrame.TextRange
              ' Write the title text to the output file
              Print #1, .TextFrame.TextRange
           End If
           End With
       Next J
   End If
   Next I
   'Close the open file
   Close #1
   End With
End Sub

Locate specific text and format the shape containing it
' ---------------------------------------------------------------------
' Copyright ?1999-2007, Shyam Pillai, All Rights Reserved.
' ---------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or 
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------
Option Explicit
' Searches for the specified text in all types of shapes
' and formats the box containing it.
' The shape reference is passed to pick up the formating
' of the desired shape for highlighting
Sub FindTextAndHighlightShape(SearchString As String, _
            oHighlightShape As Shape)
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    On Error Resume Next
    Set oSld = SlideShowWindows(1).View.Slide
    For Each oShp In oSld.Shapes
        ' I am looking for beveled autoshape since these contain the
        ' text and formatting and hence should be excluded from the
        ' search
        If oShp.Type = msoAutoShape Then
            If oShp.AutoShapeType = msoShapeBevel Then
                GoTo NextShape
            End If
        End If
        If oShp.HasTextFrame Then
            If oShp.TextFrame.HasText Then
                Set oTxtRng = oShp.TextFrame.TextRange
                Set oTmpRng = oTxtRng.Find(SearchString, , , True)
                If Not oTmpRng Is Nothing Then
                    oHighlightShape.PickUp
                    oShp.Apply
                Else
                    With oShp.Fill
                        .Visible = False
                        .Transparency = 0#
                    End With
                End If
            End If
        End If
NextShape:
    Next oShp
End Sub
' Assign this macro to the shapes containing the search text.
Sub ClickHere(oShp As Shape)
' oShp contains reference to the shape that was clicked
' to fire the macro.
' The text in the shape is passed to the search routine.
Call FindTextAndHighlightShape(oShp.TextFrame.TextRange.Text, oShp)
Call RefreshSlide
End Sub
Sub RefreshSlide()
On Error Resume Next
With SlideShowWindows(1).View
    .GotoSlide .CurrentShowPosition
End With
End Sub

Locate and highlight instances of a specific word
Locate specific text and format the shape containing it.
' ---------------------------------------------------------------------
' Copyright ?1999-2007, Shyam Pillai, All Rights Reserved.
' ---------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or 
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------
Option Explicit
' Searches for the specified text in all types of shapes
' and highlights only the text.
' The TextRange is passed to apply the formatting
' of the text for highlighting
Sub FindTextAndHighlightShape(SearchString As String, _
        oHighlightTextRange As TextRange)
    Dim oSld As Slide
    Dim oShp As Shape
    Dim oTxtRng As TextRange
    Dim oTmpRng As TextRange
    On Error Resume Next
    Set oSld = SlideShowWindows(1).View.Slide
    For Each oShp In oSld.Shapes
        ' I am looking for beveled autoshape since these contain the
        ' text and formatting and hence should be excluded from the
        ' search
        If oShp.Type = msoAutoShape Then
            If oShp.AutoShapeType = msoShapeBevel Then
                GoTo NextShape
            End If
        End If
        If oShp.HasTextFrame Then
            If oShp.TextFrame.HasText Then
                ' One needs to locate the text as well as iterate
                ' for multiple instances of the text
                Set oTxtRng = oShp.TextFrame.TextRange
                Set oTmpRng = oTxtRng.Find(SearchString, , , True)
                Do While Not oTmpRng Is Nothing
  ' Highlight the text with the desired color 
                    oTmpRng.Font.Color = oHighlightTextRange.Font.Color
                    Set oTmpRng = oTxtRng.Find(SearchString, _
                            After:=oTmpRng.Start + oTmpRng.Length, _
                            WholeWords:=True)
                Loop
            End If
        End If
NextShape:
    Next oShp
End Sub
' Assign this macro to the shapes containing the search text.
Sub ClickHere(oShp As Shape)
' oShp contains reference to the shape that was clicked
' to fire the macro.
' The text in the shape is passed to the search routine.
' The text range contains the text formating to be applied
' while highlighting the found text.
    Call FindTextAndHighlightShape(oShp.TextFrame.TextRange.Text, _
            oShp.TextFrame.TextRange)
    Call RefreshSlide
End Sub
Sub RefreshSlide()
    On Error Resume Next
    With SlideShowWindows(1).View
        .GotoSlide .CurrentShowPosition
    End With
End Sub

Set table border colour
No direct methods are available to set the table border property for native PowerPoint tables. However since the PowerPoint table just special collection of shapes, you can create a simple wrapper to achieve it. This can be extended to apply various border styles.

  ' ---------------------------------------------------------------------' Copyright ?1999-2007 Shyam Pillai. All Rights Reserved.' ---------------------------------------------------------------------' You are free to use this code within your own applications, add-ins,' documents etc but you are expressly forbidden from selling or ' otherwise distributing this source code without prior consent.' This includes both posting free demo projects made from this' code as well as reproducing the code in text or html format.' ---------------------------------------------------------------------
Option Explicit
Sub HowToUseIt()
Call SetTableBorder(ActivePresentation.Slides(1).Shapes(1).Table)
End Sub
Sub SetTableBorder(oTable As Table)
Dim I As Integer
With oTable
    For I = 1 To .Rows.Count
        With .Rows(I).Cells(1).Borders(ppBorderLeft)
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 5
        End With
        With .Rows(I).Cells(.Rows(I).Cells.Count).Borders(ppBorderRight)
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 5
        End With
    Next I
    For I = 1 To .Columns.Count
        With .Columns(I).Cells(1).Borders(ppBorderTop)
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 5
        End With
        With.Columns(I).Cells(.Columns(I).Cells.Count).Borders(ppBorderBottom)
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 5
        End With
    Next I
End With
End Sub

Native PowerPoint Table in PowerPoint 2000 or later
Sub NativeTable()
    Dim pptSlide As Slide
    Dim pptShape As Shape
    Dim pptPres As Presentation
    Dim iRow As Integer
    Dim iColumn As Integer
    Dim oShapeInsideTable As Shape
    Set pptPres = ActivePresentation
    With pptPres
        Set pptSlide = .Slides.Add(.Slides.Count, ppLayoutBlank)
    End With
    With pptSlide.Shapes

        Set pptShape = .AddTable(NumRows:=3, NumColumns:=5, Left:=30, Top:=110, Width:=660, Height:=320)
    End With
    With pptShape.Table
        For iRow = 1 To .Rows.Count
            For iColumn = 1 To .Columns.Count
                With .Cell(iRow, iColumn).Shape.TextFrame.TextRange
                    .Text = "杰堂论坛"
                    With .Font
                        .Name = "Verdana"
                        .Size = "14"
                        .Bold = msoTrue
                    End With
                End With
            Next iColumn
        Next iRow
    End With

' You can treat the table as a grouped shape too. Note that the
' items within the table have indices in reverse order.
    With pptShape.GroupItems.Range(Array(1, 2, 3))
        With .Fill
            .Visible = True
            .BackColor.SchemeColor = ppFill
        End With
        With .TextFrame.TextRange.Font
            .Italic = True
            .Color.RGB = RGB(125, 0, 125)
        End With
    End With

' Let's look at how to merge cells in a native PowerPoint table
    With pptShape.Table
        ' Insert a row at the top of the table and set it's height
        .Rows.Add BeforeRow:=1
        .Rows(1).Height = 30
        ' Now merge all the cells of the Top row
        .Cell(1, 1).Merge .Cell(1, 5)
        ' Tip: To manipulate properties of individual cells in the table
        ' get a reference to the shape which represents the cell
        ' and then manipulate it just as any PowerPoint auto shape
        ' Now grab a reference of the shape which represents the merged cell
        Set oShapeInsideTable = .Cell(1, 1).Shape
        With oShapeInsideTable
            With .TextFrame.TextRange
                .Text = "Table of contents"
                .ParagraphFormat.Alignment = ppAlignCenter
                With .Font
                    .Bold = True
                    .Size = 20
                End With
            End With
            With .Fill
                .Patterned (msoPatternDashedHorizontal)
                .ForeColor.SchemeColor = ppShadow
                .BackColor.RGB = RGB(213, 156, 87)
                .Visible = True
            End With
        End With
    End With
End Sub