ppt实用宏Word文件下载.docx

1、 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 1000.TextFrame.TextRange.Text = Format（TimeValue（Format（Now, hh:mm:ss） - _TimeSerial（Hour（Now）, Minute（Now）, Second（N

2、ow） + TMinus）, ）TMinus = TMinus - 1 Very crucial else the display wont refresh itselfDoEventsLoopEnd With 3-2-1-0 Blast off and move to the next slide or any slide for that matterSlideShowWindows（1）.View.GotoSlide （2）isRunning = FalseClick here to start countdownEnd IfEnd Sub批量删除幻灯片备注之宏代码Sub DeleteN

3、ote（）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 Sub导出备注后，需要删除PPT备注吗？导出注释bDelete = FalsebDele

4、te = TrueSet actppt = Application.ActivePresentationdirpath = actppt.Path & actppt.Name & 的备注.txtpptcount = actppt.Slides.Count打开书写文件Set fs = CreateObject（Scripting.FileSystemObjectSet a = fs.CreateTextFile（dirpath, True）遍历pptWith actpptFor i = 1 To pptcounttxtstring = .Slides（i）.NotesPage.Shapes.Pl

5、aceholders（2）.TextFrame.TextRange.TextIf （bDelete） Then.Slides（i）.NotesPage.Shapes.Placeholders（2）.TextFrame.TextRange.Text = a.writeline （.Slides（i）.SlideIndex）a.writeline （txtstring）a.writeline （Next ia.CloseUsing SetTimer/KillTimer APIAPI DeclarationsDeclare Function SetTimer Lib user32（ByVal hwn

6、d As Long, _ByVal nIDEvent As Long, _ByVal uElapse As Long, _ByVal lpTimerFunc As Long） As LongDeclare Function KillTimer Lib ByVal nIDEvent As Long） As Long Public VariablesPublic SecondCtr As IntegerPublic TimerID As LongPublic bTimerState As BooleanSub TimerOnOff（）If bTimerState = False ThenTimer

7、ID = SetTimer（0, 0, 1000, AddressOf TimerProc）If TimerID = 0 ThenMsgBox Unable to create the timer, vbCritical + vbOKOnly, ErrorbTimerState = TrueTimerID = KillTimer（0, TimerID）Unable to stop the timerbTimerState = False The defined routine gets called every nnnn milliseconds.Sub TimerProc（ByVal hwn

8、d 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）改变表格边框颜色及线条粗细之宏代码Sub HowToUseIt（）Call SetTableBorder（ActivePresentation.Slides（1）.Shapes（1）.Table）Sub SetTableBorder

9、（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 = 10With .Rows（I）.Cells（.Rows（I）.Cells.Count）.Borders（ppBorderRight）Next IFor I = 1 To .Columns.CountWith .Columns（I）.Cells（1）.Borders（ppBorderTop

10、）With .Columns（I）.Cells（.Columns（I）.Cells.Count）.Borders（ppBorderBottom）删除所有隐藏幻灯片的宏代码Sub DelHiddenSlide（）Dim sld As Slide, shp As Shape, found As BooleanDofound = FalseFor Each sld In ActivePresentation.SlidesIf sld.SlideShowTransition.Hidden = msoTrue Thenfound = Truesld.DeleteNextLoop While found

11、= TruePPT自动生成大纲宏：Dim strFileName As String Both I & J are used as countersDim J As Integer Working on the active presentation.With ActivePresentationDisplay the input box with the default Titles.TxtstrFileName = InputBox（Enter a filename to export slide titles, Provide filename.Titles.txtCheck if th

12、e user has pressed Cancel （Inputbox returns a zero length string）If strFileName = Then 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） If MsgBox（strFileName & already exists. Overwrite it?, _vbQues

13、tion + vbYesNo, Warning） = vbNo Then 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 FolderOpen .Path & strFileName For Output As #1For I = 1 To .Slides.Count Re

14、turns 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

15、inserted for debugging purposes.Debug.Print .TextFrame.TextRange Write the title text to the output filePrint #1, .TextFrame.TextRangeNext JClose the open fileClose #1Locate specific text and format the shape containing it - Copyright ?1999-2007, Shyam Pillai, All Rights Reserved. You are free to us

16、e 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. Se

17、arches 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 highlightingSub FindTextAndHighlightShape（SearchString As String, _oHighlightShape As Shape）Dim oSld As SlideDim oShp As ShapeDim oT

18、xtRng As TextRangeDim oTmpRng As TextRangeOn Error Resume NextSet oSld = SlideShowWindows（1）.View.SlideFor 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 searchIf oShp.Type = msoAutoShape ThenIf oShp.AutoS

19、hapeType = msoShapeBevel ThenGoTo NextShapeIf oShp.HasTextFrame ThenIf oShp.TextFrame.HasText ThenSet oTxtRng = oShp.TextFrame.TextRangeSet oTmpRng = oTxtRng.Find（SearchString, , , True）If Not oTmpRng Is Nothing ThenoHighlightShape.PickUpoShp.ApplyWith oShp.Fill.Visible = False.Transparency = 0#Next

20、Shape:Next oShp 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）Ca

21、ll RefreshSlideSub RefreshSlide（）With SlideShowWindows（1）.View.GotoSlide .CurrentShowPositionLocate and highlight instances of a specific wordLocate specific text and format the shape containing it. and highlights only the text. The TextRange is passed to apply the formatting of the text for highlightingoHighlightTextRange As TextRange） One needs to locate the text as well as iterate for multiple instances of the textDo While Not oTmpRng Is Nothing Highlight the text with the desired coloroTmpRng.Font.Color =