PPT常⽤宏代码PPT中常⽤宏代码倒计时宏代码Option ExplicitPublic 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 = IdleStatic isRunning As BooleanIf isRunning = True ThenEndElseisRunning = TrueDim TMinus As IntegerDim xtime As Datextime = Now'On Slide 1, Shape 1 is the textboxWith ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange.Text = "Ladies & Gentlemen." & vbCrLf & _ "Please be seated. We are about to begin." With .Shapes(1)'Countdown in secondsTMinus = 120Do While (TMinus > -1)' Suspend program execution for 1 second (1000 milliseconds)Sleep 1000xtime = 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 itselfDoEventsLoopEnd 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" EndEnd WithEnd IfEnd Sub批量删除幻灯⽚备注之宏代码Sub DeleteNote()Dim actppt As PresentationDim pptcount As IntegerDim iChose As IntegerDim bDelete As BooleanDim sMsgBox As StringDim dirpath As StringDim txtstring As StringsMsgBox = "运⾏该宏之前，请先作好备份！继续吗？"iChoice = MsgBox(sMsgBox, vbYesNo, "备份提醒")If iChoice = vbNo ThenExit SubEnd IfsMsgBox = "导出备注后，需要删除PPT备注吗？"iChoice = MsgBox(sMsgBox, vbYesNo, "导出注释")If iChoice = vbNo ThenbDelete = FalseElsebDelete = TrueEnd IfSet actppt = Application.ActivePresentationdirpath = actppt.Path & "\" & /doc/442666394.html & " 的备注.txt"pptcount = actppt.Slides.Count'打开书写⽂件Set fs = CreateObject("Scripting.FileSystemObject")Set a = fs.CreateTextFile(dirpath, True)'遍历pptWith actpptFor i = 1 To pptcounttxtstring = .Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text If (bDelete) Then .Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text = ""End Ifa.writeline (.Slides(i).SlideIndex)a.writeline (txtstring)a.writeline ("")Next iEnd Witha.CloseEnd SubUsing SetTimer/KillTimer APIOption Explicit'API DeclarationsDeclare Function SetTimer Lib "user32" _(ByVal hwnd As Long, _ByVal nIDEvent As Long, _ByVal uElapse As Long, _ByVal lpTimerFunc As Long) As LongDeclare Function KillTimer Lib "user32" _(ByVal hwnd As Long, _ByVal nIDEvent As Long) As Long' Public VariablesPublic SecondCtr As IntegerPublic TimerID As LongPublic bTimerState As BooleanSub TimerOnOff()If bTimerState = False ThenTimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)If TimerID = 0 ThenMsgBox "Unable to create the timer", vbCritical + vbOKOnly, "Error" Exit SubEnd IfbTimerState = TrueElseTimerID = KillTimer(0, TimerID)If TimerID = 0 ThenMsgBox "Unable to stop the timer", vbCritical + vbOKOnly, "Error" End IfbTimerState = FalseEnd IfEnd 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 + 1ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange.Text = CStr(SecondCtr) End Sub 改变表格边框颜⾊及线条粗细之宏代码Option ExplicitSub HowToUseIt()Call SetTableBorder(ActivePresentation.Slides(1).Shapes(1).Table)End SubSub SetTableBorder(oTable As Table)Dim I As IntegerWith oTableFor I = 1 To .Rows.CountWith .Rows(I).Cells(1).Borders(ppBorderLeft).ForeColor.RGB = RGB(255, 153, 51).Weight = 10End WithWith .Rows(I).Cells(.Rows(I).Cells.Count).Borders(ppBorderRight).ForeColor.RGB = RGB(255, 153, 51).Weight = 10End WithNext IFor I = 1 To .Columns.CountWith .Columns(I).Cells(1).Borders(ppBorderTop).ForeColor.RGB = RGB(255, 153, 51).Weight = 10End WithWith .Columns(I).Cells(.Columns(I).Cells.Count).Borders(ppBorderBottom).ForeColor.RGB = RGB(255, 153, 51).Weight = 10End WithNext IEnd WithEnd Sub删除所有隐藏幻灯⽚的宏代码Sub DelHiddenSlide()Dim sld As Slide, shp As Shape, found As BooleanDofound = FalseFor Each sld In ActivePresentation.SlidesIf sld.SlideShowTransition.Hidden = msoTrue Thenfound = Truesld.DeleteEnd IfNextLoop While found = TrueEnd SubPPT⾃动⽣成⼤纲宏：Dim strFileName As String' Both I & J are used as countersDim I As IntegerDim 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 = "" ThenExit SubEnd 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) <> "" ThenIf MsgBox(strFileName & " already exists. Overwrite it?", _vbQuestion + vbYesNo, "Warning") = vbNo ThenExit SubEnd IfEnd 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 #1For I = 1 To .Slides.Count' Returns TRUE if there is a TitlePlaceholderIf .Slides(I).Shapes.HasTitle Then' Now loop thru the PlaceHolders and pick the text from the TitlePlaceHolderFor J = 1 To .Slides(I).Shapes.Placeholders.CountWith .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 filePrint #1, .TextFrame.TextRangeEnd IfEnd WithNext JEnd IfNext I'Close the open fileClose #1End WithEnd Sub。
