PPT中常用宏代码
倒计时宏代码
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, "导出注释")
delete in
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", "", "")
'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)

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。