ppt实用宏.docx - 冰点文库

资源描述

ppt实用宏.docx

《ppt实用宏.docx》由会员分享，可在线阅读，更多相关《ppt实用宏.docx（25页珍藏版）》请在冰点文库上搜索。

ppt实用宏.docx

ppt实用宏

倒计时宏代码

OptionExplicit

PublicDeclareSubSleepLib"kernel32"（ByValdwMillisecondsAsLong）

SubTmr（）

'Justintheeventualitythatyouclickthestartbuttontwice

'isRunningstoresthecurrentstateofthemacro

'TRUE=Running;FALSE=Idle

StaticisRunningAsBoolean

IfisRunning=TrueThen

End

Else

isRunning=True

DimTMinusAsInteger

DimxtimeAsDate

xtime=Now

'OnSlide1,Shape1isthetextbox

WithActivePresentation.Slides

（1）

.Shapes

（2）.TextFrame.TextRange.Text="Ladies&Gentlemen."&vbCrLf&_

"Pleasebeseated.Weareabouttobegin."

With.Shapes

（1）

'Countdowninseconds

TMinus=120

DoWhile（TMinus>-1）

'Suspendprogramexecutionfor1second（1000milliseconds）

Sleep1000

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

'Verycrucialelsethedisplaywon'trefreshitself

DoEvents

Loop

EndWith

'3-2-1-0Blastoffandmovetothenextslideoranyslideforthatmatter

SlideShowWindows

（1）.View.GotoSlide

（2）

isRunning=False

.Shapes

（2）.TextFrame.TextRange.Text="Clickheretostartcountdown"

End

EndWith

EndIf

EndSub

批量删除幻灯片备注之宏代码

SubDeleteNote（）

DimactpptAsPresentation

DimpptcountAsInteger

DimiChoseAsInteger

DimbDeleteAsBoolean

DimsMsgBoxAsString

DimdirpathAsString

DimtxtstringAsString

sMsgBox="运行该宏之前，请先作好备份！

继续吗？

iChoice=MsgBox（sMsgBox,vbYesNo,"备份提醒"）

IfiChoice=vbNoThen

ExitSub

EndIf

sMsgBox="导出备注后，需要删除PPT备注吗？

iChoice=MsgBox（sMsgBox,vbYesNo,"导出注释"）

IfiChoice=vbNoThen

bDelete=False

Else

bDelete=True

EndIf

Setactppt=Application.ActivePresentation

dirpath=actppt.Path&"\"&actppt.Name&"的备注.txt"

pptcount=actppt.Slides.Count

'打开书写文件

Setfs=CreateObject（"Scripting.FileSystemObject"）

Seta=fs.CreateTextFile（dirpath,True）

'遍历ppt

Withactppt

Fori=1Topptcount

txtstring=.Slides（i）.NotesPage.Shapes.Placeholders

（2）.TextFrame.TextRange.Text

If（bDelete）Then

.Slides（i）.NotesPage.Shapes.Placeholders

（2）.TextFrame.TextRange.Text=""

EndIf

a.writeline（.Slides（i）.SlideIndex）

a.writeline（txtstring）

a.writeline（""）

Nexti

EndWith

a.Close

EndSub

UsingSetTimer/KillTimerAPI

OptionExplicit

'APIDeclarations

DeclareFunctionSetTimerLib"user32"_

（ByValhwndAsLong,_

ByValnIDEventAsLong,_

ByValuElapseAsLong,_

ByVallpTimerFuncAsLong）AsLong

DeclareFunctionKillTimerLib"user32"_

（ByValhwndAsLong,_

ByValnIDEventAsLong）AsLong

'PublicVariables

PublicSecondCtrAsInteger

PublicTimerIDAsLong

PublicbTimerStateAsBoolean

SubTimerOnOff（）

IfbTimerState=FalseThen

TimerID=SetTimer（0,0,1000,AddressOfTimerProc）

IfTimerID=0Then

MsgBox"Unabletocreatethetimer",vbCritical+vbOKOnly,"Error"

ExitSub

EndIf

bTimerState=True

Else

TimerID=KillTimer（0,TimerID）

IfTimerID=0Then

MsgBox"Unabletostopthetimer",vbCritical+vbOKOnly,"Error"

EndIf

bTimerState=False

EndIf

EndSub

'Thedefinedroutinegetscalledeverynnnnmilliseconds.

SubTimerProc（ByValhwndAsLong,_

ByValuMsgAsLong,_

ByValidEventAsLong,_

ByValdwTimeAsLong）

SecondCtr=SecondCtr+1

ActivePresentation.Slides

（1）.Shapes

（2）.TextFrame.TextRange.Text=CStr（SecondCtr）

EndSub

改变表格边框颜色及线条粗细之宏代码

OptionExplicit

SubHowToUseIt（）

CallSetTableBorder（ActivePresentation.Slides

（1）.Shapes

（1）.Table）

EndSub

SubSetTableBorder（oTableAsTable）

DimIAsInteger

WithoTable

ForI=1To.Rows.Count

With.Rows（I）.Cells

（1）.Borders（ppBorderLeft）

.ForeColor.RGB=RGB（255,153,51）

.Weight=10

EndWith

With.Rows（I）.Cells（.Rows（I）.Cells.Count）.Borders（ppBorderRight）

.ForeColor.RGB=RGB（255,153,51）

.Weight=10

EndWith

NextI

ForI=1To.Columns.Count

With.Columns（I）.Cells

（1）.Borders（ppBorderTop）

.ForeColor.RGB=RGB（255,153,51）

.Weight=10

EndWith

With.Columns（I）.Cells（.Columns（I）.Cells.Count）.Borders（ppBorderBottom）

.ForeColor.RGB=RGB（255,153,51）

.Weight=10

EndWith

NextI

EndWith

EndSub

删除所有隐藏幻灯片的宏代码

SubDelHiddenSlide（）

DimsldAsSlide,shpAsShape,foundAsBoolean

found=False

ForEachsldInActivePresentation.Slides

Ifsld.SlideShowTransition.Hidden=msoTrueThen

found=True

sld.Delete

EndIf

LoopWhilefound=True

EndSub

PPT自动生成大纲宏：

DimstrFileNameAsString

'BothI&Jareusedascounters

DimIAsInteger

DimJAsInteger

'Workingontheactivepresentation.

WithActivePresentation

'Displaytheinputboxwiththedefault'Titles.Txt'

strFileName=InputBox（"Enterafilenametoexportslidetitles","Providefilename...","Titles.txt"）

'CheckiftheuserhaspressedCancel（Inputboxreturnsazerolengthstring）

IfstrFileName=""Then

ExitSub

EndIf

'Dosomegoodhousekeepingandcheckfortheexistenceofthefile.

'Asktheuserforfurtherdirectionsincaseitdoes.:

）

IfDir（.Path&"\"&strFileName）<>""Then

IfMsgBox（strFileName&"alreadyexists.Overwriteit?

",_

vbQuestion+vbYesNo,"Warning"）=vbNoThen

ExitSub

EndIf

'Openthefileforexportingtheslidetitles.Fileiscreatedinthesamefolderastheopenpresentation.

'IfthePresentationisanewone（Nopath）thenitwillgetcreatedintheRootFolder

Open.Path&"\"&strFileNameForOutputAs#1

ForI=1To.Slides.Count

'ReturnsTRUEifthereisaTitlePlaceholder

If.Slides（I）.Shapes.HasTitleThen

'NowloopthruthePlaceHoldersandpickthetextfromtheTitlePlaceHolder

ForJ=1To.Slides（I）.Shapes.Placeholders.Count

With.Slides（I）.Shapes.Placeholders.Item（J）

If.PlaceholderFormat.Type=ppPlaceholderTitleThen

'Justinsertedfordebuggingpurposes...

Debug.Print.TextFrame.TextRange

'Writethetitletexttotheoutputfile

Print#1,.TextFrame.TextRange

EndIf

EndWith

NextJ

EndIf

NextI

'Closetheopenfile

Close#1

EndWith

EndSub

Locatespecifictextandformattheshapecontainingit

'---------------------------------------------------------------------

'Copyright?

1999-2007,ShyamPillai,AllRightsReserved.

'---------------------------------------------------------------------

'Youarefreetousethiscodewithinyourownapplications,add-ins,

'documentsetcbutyouareexpresslyforbiddenfromsellingor

'otherwisedistributingthissourcecodewithoutpriorconsent.

'Thisincludesbothpostingfreedemoprojectsmadefromthis

'codeaswellasreproducingthecodeintextorhtmlformat.

'---------------------------------------------------------------------

OptionExplicit

'Searchesforthespecifiedtextinalltypesofshapes

'andformatstheboxcontainingit.

'Theshapereferenceispassedtopickuptheformating

'ofthedesiredshapeforhighlighting

SubFindTextAndHighlightShape（SearchStringAsString,_

oHighlightShapeAsShape）

DimoSldAsSlide

DimoShpAsShape

DimoTxtRngAsTextRange

DimoTmpRngAsTextRange

OnErrorResumeNext

SetoSld=SlideShowWindows

（1）.View.Slide

ForEachoShpInoSld.Shapes

'Iamlookingforbeveledautoshapesincethesecontainthe

'textandformattingandhenceshouldbeexcludedfromthe

'search

IfoShp.Type=msoAutoShapeThen

IfoShp.AutoShapeType=msoShapeBevelThen

GoToNextShape

EndIf

IfoShp.HasTextFrameThen

IfoShp.TextFrame.HasTextThen

SetoTxtRng=oShp.TextFrame.TextRange

SetoTmpRng=oTxtRng.Find（SearchString,,,True）

IfNotoTmpRngIsNothingThen

oHighlightShape.PickUp

oShp.Apply

Else

WithoShp.Fill

.Visible=False

.Transparency=0#

EndWith

EndIf

NextShape:

NextoShp

EndSub

'Assignthismacrototheshapescontainingthesearchtext.

SubClickHere（oShpAsShape）

'oShpcontainsreferencetotheshapethatwasclicked

'tofirethemacro.

'Thetextintheshapeispassedtothesearchroutine.

CallFindTextAndHighlightShape（oShp.TextFrame.TextRange.Text,oShp）

CallRefreshSlide

EndSub

SubRefreshSlide（）

OnErrorResumeNext

WithSlideShowWindows

（1）.View

.GotoSlide.CurrentShowPosition

EndWith

EndSub

Locateandhighlightinstancesofaspecificword

Locatespecifictextandformattheshapecontainingit.

'---------------------------------------------------------------------

'Copyright?

1999-2007,ShyamPillai,AllRightsReserved.

'---------------------------------------------------------------------

'Youarefreetousethiscodewithinyourownapplications,add-ins,

'documentsetcbutyouareexpresslyforbiddenfromsellingor

'otherwisedistributingthissourcecodewithoutpriorconsent.

'Thisincludesbothpostingfreedemoprojectsmadefromthis

'codeaswellasreproducingthecodeintextorhtmlformat.

'---------------------------------------------------------------------

OptionExplicit

'Searchesforthespecifiedtextinalltypesofshapes

'andhighlightsonlythetext.

'TheTextRangeispassedtoapplytheformatting

'ofthetextforhighlighting

SubFindTextAndHighlightShape（SearchStringAsString,_

oHighlightTextRangeAsTextRange）

DimoSldAsSlide

DimoShpAsShape

DimoTxtRngAsTextRange

DimoTmpRngAsTextRange

OnErrorResumeNext

SetoSld=SlideShowWindows

（1）.View.Slide

ForEachoShpInoSld.Shapes

'Iamlookingforbeveledautoshapesincethesecontainthe

'textandformattingandhenceshouldbeexcludedfromthe

'search

IfoShp.Type=msoAutoShapeThen

IfoShp.AutoShapeType=msoShapeBevelThen

GoToNextShape

EndIf

IfoShp.HasTextFrameThen

IfoShp.TextFrame.HasTextThen

'Oneneedstolocatethetextaswellasiterate

'formultipleinstancesofthetext

SetoTxtRng=oShp.TextFrame.TextRange

SetoTmpRng=oTxtRng.Find（SearchString,,,True）

DoWhileNotoTmpRngIsNothing

'Highlightthetextwiththedesiredcolor

oTmpRng.Font.Colo

展开阅读全文