ppt实用宏.docx

1、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 twiceisRunning stores the current state of the macroTRUE = Running; FALSE = IdleStatic isRunning As BooleanIf isRunning = True ThenEnd

2、ElseisRunning = TrueDim TMinus As IntegerDim xtime As Datextime = NowOn 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 Whil

3、e (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 wont refresh itselfD

4、oEventsLoopEnd With 3-2-1-0 Blast off and move to the next slide or any slide for that matterSlideShowWindows(1).View.GotoSlide (2)isRunning = False.Shapes(2).TextFrame.TextRange.Text = Click here to start countdownEndEnd WithEnd IfEnd Sub批量删除幻灯片备注之宏代码Sub DeleteNote()Dim actppt As PresentationDim pp

5、tcount 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 i

6、Choice = vbNo ThenbDelete = FalseElsebDelete = TrueEnd IfSet actppt = Application.ActivePresentationdirpath = actppt.Path & & actppt.Name & 的备注.txtpptcount = actppt.Slides.Count打开书写文件Set fs = CreateObject(Scripting.FileSystemObject)Set a = fs.CreateTextFile(dirpath, True)遍历pptWith actpptFor i = 1 To

7、 pptcounttxtstring = .Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.TextIf (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/Ki

8、llTimer APIOption ExplicitAPI 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

9、 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, ErrorExit SubEnd IfbTimerState = TrueElseTimerID = KillTi

10、mer(0, TimerID)If TimerID = 0 ThenMsgBox Unable to stop the timer, vbCritical + vbOKOnly, ErrorEnd 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

11、 = 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 .

12、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(ppBorde

13、rTop).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 = Fals

14、eFor 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 ActiveP

15、resentationDisplay the input box with the default Titles.TxtstrFileName = 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 chec

16、k 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 crea

17、ted 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 Returns TRUE if there is a TitlePlaceholderIf .Slides(I).Shapes.HasTitle Then Now loop thru the

18、 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

19、output filePrint #1, .TextFrame.TextRangeEnd IfEnd WithNext JEnd IfNext IClose the open fileClose #1End WithEnd SubLocate 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,

20、 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

21、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 oTxtRng As TextRangeDim oTmpRng As

22、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.AutoShapeType = msoShapeBevel ThenGoTo

23、 NextShapeEnd IfEnd IfIf oShp.HasTextFrame ThenIf oShp.TextFrame.HasText ThenSet oTxtRng = oShp.TextFrame.TextRangeSet oTmpRng = oTxtRng.Find(SearchString, , , True)If Not oTmpRng Is Nothing ThenoHighlightShape.PickUpoShp.ApplyElseWith oShp.Fill.Visible = False.Transparency = 0#End WithEnd IfEnd IfE

24、nd IfNextShape:Next oShpEnd 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.TextRan

25、ge.Text, oShp)Call RefreshSlideEnd SubSub RefreshSlide()On Error Resume NextWith SlideShowWindows(1).View.GotoSlide .CurrentShowPositionEnd WithEnd SubLocate and highlight instances of a specific wordLocate specific text and format the shape containing it. - Copyright ?1999-2007, Shyam Pillai, All R

26、ights 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

27、 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 highlightingSub FindTextAndHighlightShape(SearchString As String, _oHighlightTextRange As TextRange)

28、Dim oSld As SlideDim oShp As ShapeDim oTxtRng 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 oS

29、hp.Type = msoAutoShape ThenIf oShp.AutoShapeType = msoShapeBevel ThenGoTo NextShapeEnd IfEnd IfIf oShp.HasTextFrame ThenIf oShp.TextFrame.HasText Then One needs to locate the text as well as iterate for multiple instances of the textSet oTxtRng = oShp.TextFrame.TextRangeSet oTmpRng = oTxtRng.Find(SearchString, , , True)Do While Not oTmpRng Is Nothing Highlight the text with the desired coloroTmpRng.Font.Color =