前往顾页
以后地位: 主页 > 精通Office > PowerPoint教程 >

PPT幻灯片中常常利用的一些宏年夜全

时候:2011-02-19 19:17来源:知行网www.zhixing123.cn 编辑:麦田守望者

倒计时宏代码
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Tmr()
'Just in the eventuality that you click the start button twice
'isRunning stores the current state of the macro
'TRUE = Running; FALSE = Idle
Static isRunning As Boolean
If isRunning = True Then
End
Else
isRunning = True
Dim TMinus As Integer
Dim xtime As Date
xtime = Now
'On Slide 1, Shape 1 is the textbox
With ActivePresentation.Slides(1)
.Shapes(2).TextFrame.TextRange.Text = "Ladies & Gentlemen." & vbCrLf & _
"Please be seated. We are about to begin."
With .Shapes(1)
'Countdown in seconds
TMinus = 120
Do While (TMinus > -1)
' Suspend program execution for 1 second (1000 milliseconds)
Sleep 1000
xtime = Now
.TextFrame.TextRange.Text = Format(TimeValue(Format(Now, "hh:mm:ss")) - _
TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), "hh:mm:ss")
TMinus = TMinus - 1
' Very crucial else the display won't refresh itself
DoEvents
Loop
End With
' 3-2-1-0 Blast off and move to the next slide or any slide for that matter
SlideShowWindows(1).View.GotoSlide (2)
isRunning = False
.Shapes(2).TextFrame.TextRange.Text = "Click here to start countdown"
End

End With
End If
End Sub

批量删除幻灯片备注之宏代码
Sub DeleteNote()
Dim actppt As Presentation
Dim pptcount As Integer
Dim iChose As Integer
Dim bDelete As Boolean
Dim sMsgBox As String
Dim dirpath As String
Dim txtstring As String


sMsgBox = "运行该宏之前,请先作好备份!继续吗?"
iChoice = MsgBox(sMsgBox, vbYesNo, "备份提示")
If iChoice = vbNo Then
Exit Sub
End If
sMsgBox = "导出备注后,需求删除PPT备注吗?"
iChoice = MsgBox(sMsgBox, vbYesNo, "导出注释")
If iChoice = vbNo Then
bDelete = False
Else
bDelete = True
End If


Set actppt = Application.ActivePresentation
dirpath = actppt.Path & "\" & actppt.Name & " 的备注.txt"
pptcount = actppt.Slides.Count

'翻开誊写文件
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(dirpath, True)

'遍历ppt
With actppt
For i = 1 To pptcount
txtstring = .Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
If (bDelete) Then
.Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text = ""
End If

a.writeline (.Slides(i).SlideIndex)
a.writeline (txtstring)
a.writeline ("")

Next i
End With

a.Close

End Sub

Using SetTimer/KillTimer API
Option Explicit
'API Declarations
Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long

' Public Variables
Public SecondCtr As Integer
Public TimerID As Long
Public bTimerState As Boolean

Sub TimerOnOff()
If bTimerState = False Then
TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)
If TimerID = 0 Then
MsgBox "Unable to create the timer", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
bTimerState = True
Else
TimerID = KillTimer(0, TimerID)
If TimerID = 0 Then
MsgBox "Unable to stop the timer", vbCritical + vbOKOnly, "Error"
End If
bTimerState = False
End If
End Sub

' The defined routine gets called every nnnn milliseconds.
Sub TimerProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
SecondCtr = SecondCtr + 1
ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange.Text = CStr(SecondCtr)
End Sub

改变表格边框色彩及线条粗细之宏代码
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, 153, 51)
.Weight = 10
End With
With .Rows(I).Cells(.Rows(I).Cells.Count).Borders(ppBorderRight)
.ForeColor.RGB = RGB(255, 153, 51)
.Weight = 10
End With
Next I
For I = 1 To .Columns.Count
With .Columns(I).Cells(1).Borders(ppBorderTop)
.ForeColor.RGB = RGB(255, 153, 51)
.Weight = 10
End With
With .Columns(I).Cells(.Columns(I).Cells.Count).Borders(ppBorderBottom)
.ForeColor.RGB = RGB(255, 153, 51)
.Weight = 10
End With
Next I
End With
End Sub

删除所有埋没幻灯片的宏代码
Sub DelHiddenSlide()
Dim sld As Slide, shp As Shape, found As Boolean
Do
found = False
For Each sld In ActivePresentation.Slides
If sld.SlideShowTransition.Hidden = msoTrue Then
found = True
sld.Delete
End If
Next
Loop While found = True
End Sub

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,

------分开线----------------------------
标签(Tag):ppt PowerPoint powerpoint2007 幻灯片 powerpoint2010
------分开线----------------------------
保举内容
猜你感兴趣