ppt实用宏.doc

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 ThenEndElseisRunning = 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 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 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 = False.Shapes(2).TextFrame.TextRange.Text = Click here to start countdownEndEnd 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 & & actppt.Name & 的备注.txtpptcount = 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.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/KillTimer 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 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 = KillTimer(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 = 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 ActivePresentationDisplay 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 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 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 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 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, 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 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 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 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 IfEnd 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.TextRange.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 Rights 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 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)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 oShp.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 = oHighlightTextRange.Font.ColorSet oTmpRng = oTxtRng.Find(SearchString, _After:=oTmpRng.Start + oTmpRng.Length, _WholeWords:=True)LoopEnd IfEnd 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. The text range contains the text formating to be applied while highlighting the found text.Call FindTextAndHighlightShape(oShp.TextFrame.TextRange.Text, _oShp.TextFrame.TextRange)Call RefreshSlideEnd SubSub RefreshSlide()On Error Resume NextWith SlideShowWindows(1).View.GotoSlide .CurrentShowPositionEnd WithEnd SubSet table border colourNo direct methods are available to set the table border property for native PowerPoint tables. However since the PowerPoint table just special collection of shapes, you can create a simple wrapper to achieve it. This can be extended to apply various border styles. - Copyright ?1999-2007 Shyam Pillai. All Rights 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 the code in text or html format. -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, 0, 0).Weight = 5End WithWith .Rows(I).Cells(.Rows(I).Cells.Count).Borders(ppBorderRight).ForeColor.RGB = RGB(255, 0, 0).Weight = 5End WithNext IFor I = 1 To .Columns.CountWith .Columns(I).Cells(1).Borders(ppBorderTop).ForeColor.RGB = RGB(255, 0, 0).Weight = 5End WithWith.Columns(I).Cells(.Columns(I).Cells.Count).Borders(ppBorderBottom).ForeColor.RGB = RGB(255, 0, 0).Weight = 5End WithNext IEnd WithEnd SubNative PowerPoint Table in PowerPoint 2000 or laterSub NativeTable()Dim pptSlide As SlideDim pptShape As ShapeDim pptPres As PresentationDim iRow As IntegerDim iColumn As IntegerDim oShapeInsideTable As ShapeSet pptPres = ActivePresentationWith pptPresSet pptSlide = .Slides.Add(.Slides.Count, ppLayoutBlank)End WithWith pptSlide.ShapesSet pptShape = .AddTable(NumRows:=3, NumColumns:=5, Left:=30, Top:=110, Width:=660, Height:=320)End WithWith pptShape.TableFor iRow = 1 To .Rows.CountFor iColumn = 1 To .Columns.CountWith .Cell(iRow, iColumn).Shape.TextFrame.TextRange.Text = 杰堂论坛With .Font.Name = Verdana.Size = 14.Bold = msoTrueEnd WithEnd WithNext iColumnNext iRowEnd With You can treat the table as a grouped shape too. Note that the items within the table have indices in reverse order.With pptShape.GroupItems.Range(Array(1, 2, 3)With .Fill.Visible = True.BackColor.SchemeColor = ppFillEnd WithWith .TextFrame.TextRange.Font.Italic = True.Color.RGB = RGB(125, 0, 125)End WithEnd With Lets look at how to merge cells in a native PowerPoint tableWith pptShape.Table Insert a row at the top of the table and set its height.Rows.Add BeforeRow:=1.Rows(1).Height = 30 Now merge all the cells of the Top row.Cell(1, 1).Merge .Cell(1, 5) Tip: To manipulate properties of individual cells in the table get a reference to the shape which represents the cell and then manipulate it just as any PowerPoint auto shape Now grab a reference of the shape which represents the merged cellSet oShapeInsideTable = .Cell(1, 1).ShapeWith oShapeInsideTableWith .TextFrame.TextRange.Text = Table of contents.ParagraphFormat.Alignment = ppAlignCenterWith .Font.Bold = True.Size = 20End WithEnd WithWith .Fill.Patterned (msoPatternDashedHorizontal).ForeColor.SchemeColor = ppShadow.BackColor.RGB = RGB(213, 156, 87).Visible = TrueEnd WithEnd WithEnd WithEnd Sub快速合并PPTOption ExplicitSub CopyWithSourceFormating()Dim oSource As PresentationDim oTarget As PresentationDim oSlide As SlideDim dlgOpen As FileDialogDim bMasterShapes As BooleanSet oTarget = ActivePresentationSet dlgOpen = Application.FileDialog(msoFileDialogOpen)With dlgOpen.AllowMultiSelect = False.Filters.Clear.Filters.Add Presentations, *.ppt,*.pps.Title = Select Presentation to importIf .Show = -1 ThenSet oSource = Presentations.Open(.SelectedItems(1), , , False)End IfIf oSource Is Nothing Then Exit SubEnd WithFor Each oSlide In oSource.SlidesoSlide.CopyWith oTarget.Slides.Paste.Design = oSlide.Design Apply the color scheme only after you have applied the design, else it wont give the desired results.ColorScheme = oSlide.ColorScheme Additional processing for slides which dont follow the master backgroundIf oSlide.FollowMasterBackground = False Then.FollowMasterBackground = FalseWith .Background.Fill.Visible = oSlide.Background.Fill.Visible.ForeColor = oSlide.Background.Fill.ForeColor.BackColor = oSlide.Background.Fill.BackColorEnd WithSelect Case oSlide.Background.Fill.TypeCase Is = msoFillTexturedSelect Case oSlide.Background.Fill.TextureTypeCase Is = msoTexturePreset.Background.Fill.PresetTextured _(oSlide.Background.Fill.PresetTexture)Case Is = msoTextureUserDefined TextureName gives only the filename and not the path to the custom texture file used. We could do it the same way we handle picture fill.End SelectCase Is = msoFillSolid.Background.Fill.Transparency = 0#.Background.Fill.SolidCase Is = msoFillPicture No way to get the picture so export the slide image.With oSlideIf .Shapes.Count0 Then .Shapes.Range.Visible=FalsebMasterShapes = .DisplayMasterShapes.DisplayMasterShapes = False.Export oSource.Path & .SlideID & .png, PNGEnd With.Background.Fill.UserPicture _oSource.Path & oSlide.SlideID & .pngKill (oSource.Path & oSlide.SlideID & .png)With oSlide.DisplayMasterShapes = bMasterShapesIf .Shapes.Count0 Then .Shapes.Range.Visible= TrueEnd WithCase Is = msoFillPatterned.Background.Fill.Patterned _(oSlide.Background.Fill.Pattern)Case Is = msoFillGradientSelect Case oSlide.Background.Fill.GradientColorTypeCase Is = msoGradientTwoColors.Background.Fill.TwoColorGradient _oSlide.Background.Fill.GradientStyle, _oSlide.Background.Fill.GradientVariantCase Is = msoGradientPresetColors.Background.Fill.PresetGradient _oSlide.Background.Fill.GradientStyle, _oSlide.Background.Fill.GradientVariant, _oSlide.Background.Fill.PresetGradientTypeCase Is = msoGradientOneColor.Background.Fill.OneColorGradient _oSlide.Background.Fill.GradientStyle, _oSlide.Background.Fill.GradientVariant, _oSlide.Background.Fill.GradientDegreeEnd SelectCase Is = msoFillBackground Only applicable to shapes.End SelectEnd IfEnd WithNext oSlideoSource.CloseSet oSource = NothingEnd Sub一、难寻的PowerPoint自动运行宏Office系统中的主要程序几乎都有内置的能自动运行的宏，可对于PowerPoint，我查看了所能收集到的所有资料，包括微软的官方网站及其Office开发资源网站MSDN上的中英文资料，都说它不具有自动运行的宏，最后又“白度”中国，“Google”世界，再“Yahoo”全球，还是没有找到说PowerPoint有自动运行宏的资料，有的只有说在PowerPoint的Add-In（加载项）插件中有自动化运行的宏Auto_Open和Auto_Close。作为开发工具，没有内置的自动化运行的宏是肯定不行的，难道初始化程序的运行环境，程序运行中要自动完成某个操作，程序运行结束后环境的清理等等，这些操作都要我们开发一个加载项插件到每个需要运行我们程序的电脑上去安装？这太可怕了，真的像有人所说的PowerPoint不适合用作多媒体课件开发的平台吗？这么易用的PowerPoint就这样被废掉了吗？不，决不。经过本人多方查找和测试，终于发现了两个神秘的宏：OnSlideShowPageChange和OnSlideShowTerminate，它们能在演示文稿开始放映、放映过程中及放映结束时自动运行，实现我们自动化的要求。二、OnSlideShowPageChange宏的使用下面我们来研究一下这两个宏的功能与运行的条件。先来看OnSlideShowPageChange宏，我们新建一个演示文稿，并把PowerPoint宏的安全级别设置为启用全部宏，在演示文稿中添加几张幻灯片，为便于测试说明，从第一张幻灯片开始，我们按顺序给它们输入数字编号“1、2、3、4”，再按Alt+F11快捷键启动VBA编辑器，在其中插入一个模块，向代码窗口中输入如下代码：Sub On